VBA ユーザーフォームからアクティブシート1a1に転記した後、シート2の- Excel（エクセル）

QExcelでデータの抽出＆別シート転記をマクロで行いたい(VBA)

はじめまして、Excel2010を使用しています。

添付画像のように1つのブックにリストと注文表という2つのシートがあり、
注文表B列の登録番号と一致するデータをリストから抽出して別シートに転記し、
注文表のA列(受注日)・B列(登録番号)・リストのG列(商品名)・H列(個数)・注文表のC列
(注文数)・個数に注文数をかけた数量を入れる列の6列構成の表にする作業をしています。

リストのデータは毎週連番で新規追加され、現在は10000行超のデータが入っていますが、
空白セルが多くフィルターも使えません。...続きを読む

Aベストアンサー

標準モジュールへ登録してください。（手配リストも作成しておいてください。ないとエラーになります。）
文字数オーバーなので2回に分けます。（1回位目）
---------------------------------------
Option Explicit
Dim sh1 As Worksheet
Dim sh2 As Worksheet
Dim sh3 As Worksheet
Dim dicT As Object '登録番号の出現行を保持
Dim dicS As Object '登録番号に一致する商品の開始行を保持（|で区切って複数もつ）
Dim dicE As Object '登録番号に一致する商品の終了行を保持（|で区切って複数もつ）
Dim errmsg As String
Public Sub 手配書作成()
Set sh1 = Worksheets("リスト")
Set sh2 = Worksheets("注文表")
Set sh3 = Worksheets("手配リスト")
Set dicT = CreateObject("Scripting.Dictionary") ' 連想配列の定義
Set dicS = CreateObject("Scripting.Dictionary") ' 連想配列の定義
Set dicE = CreateObject("Scripting.Dictionary") ' 連想配列の定義
errmsg = ""
'リストを読み込み登録番号の連想配列を作成する
Call GetNumber
'注文表を読み込み手配リストを作成
Call Tehai
'重複番号のエラーを表示
If errmsg <> "" Then
MsgBox (errmsg)
End If
MsgBox ("処理完了")
End Sub
'手配リスト作成
Private Sub Tehai()
Dim maxrow As Long
Dim row1 As Long
Dim row2 As Long
Dim row3 As Long
Dim i As Long
Dim key As Variant
Dim srows As Variant
Dim erows As Variant
'手配リスト２行目以降をクリア
maxrow = sh3.Cells(sh1.Rows.Count, "A").End(xlUp).row
sh3.Range("A2:F" & maxrow).Value = ""
row3 = 2
maxrow = sh2.Cells(sh1.Rows.Count, "A").End(xlUp).row
For row2 = 2 To maxrow '2行～最後の行まで繰り返す
key = sh2.Cells(row2, "B").Value
If dicT.exists(key) = False Then
MsgBox ("注文表の登録番号がリストになし　行番号=" & row2 & "　登録番号=" & key)
sh2.Activate
sh2.Cells(row2, "B").Select
End
End If
'登録番号に対応する商品の開始行と終了行を取得
srows = Split(dicS(key), "|")
erows = Split(dicE(key), "|")
For i = 0 To UBound(srows) '複数の登録番号分繰り返す
For row1 = CLng(srows(i)) To CLng(erows(i)) '商品の数分繰り返す
sh3.Cells(row3, "A").Value = sh2.Cells(row2, "A").Value '受注日
sh3.Cells(row3, "B").Value = sh2.Cells(row2, "B").Value '登録番号
sh3.Cells(row3, "C").Value = sh1.Cells(row1, "G").Value '商品名
sh3.Cells(row3, "D").Value = sh1.Cells(row1, "H").Value '個数
sh3.Cells(row3, "E").Value = sh2.Cells(row2, "C").Value '注文数
sh3.Cells(row3, "F").Value = sh3.Cells(row3, "D").Value * sh3.Cells(row3, "E").Value '合計(個数×注文数)
row3 = row3 + 1
Next
Next
Next
End Sub
'登録番号取得
Private Sub GetNumber()
Dim maxrow As Long
Dim maxrow2 As Long
Dim row As Long
Dim srow As Long
Dim erow As Long
srow = 0
'C列とF列の大きい方を最終行番号とする
maxrow = sh1.Cells(sh1.Rows.Count, "F").End(xlUp).row
maxrow2 = sh1.Cells(sh1.Rows.Count, "C").End(xlUp).row
If maxrow2 > maxrow Then maxrow = maxrow2
For row = 2 To maxrow
'登録番号の開始位置検知
If sh1.Cells(row, "A").Value <> "" Then
Call CheckRow(row, 2, 8) '行チェック
Call makeDict(srow, row - 1) '登録番号の辞書登録（空白行がない場合の保険）
srow = row
End If
'登録番号の終了位置検知
If sh1.Cells(row, "C").Value = "" And sh1.Cells(row, "F").Value = "" Then
Call makeDict(srow, row - 1) '登録番号の辞書登録
srow = 0
End If
Next
Call makeDict(srow, row - 1) '（空白行がない場合の保険）
End Sub

標準モジュールへ登録してください。（手配リストも作成しておいてください。ないとエラーになります。）
文字数オーバーなので2回に分けます。（1回位目）
---------------------------------------
Option Explicit
Dim sh1 As Worksheet
Dim sh2 As Worksheet
Dim sh3 As Worksheet
Dim dicT As Object '登録番号の出現行を保持
Dim dicS As Object '登録番号に一致する商品の開始行を保持（|で区切って複数もつ）
Dim dicE As Object '登録番号に一致する商品の終了行を保持（|で区切って複数...続きを読む

他の回答も見る

Qエクセルセル内の除去について

エクセルのセル一つについて　「〇○○　　×××　　」と文字○があった場合、〇○○の右の空白のスペースからすべて右側を×××を含めて除去する方法はありませんか。〇○○、×××の文字、文字数はセルごとに違うものとします。

Aベストアンサー

例えば、
A1に、

> 「〇○○　　×××　　」

が入力されているとして、

B1に、
=FIND("　",A1)
で最初に空白文字が現れる文字の場所を取得。

C1に、
=LEFT(A1,B1-1)
で最初に空白が現れるより左の文字列を取得。

とか。

他の回答も見る

Qマクロ繰り返しコピー方法

いつもお世話になっております。
マクロ初心者です。

2つのシートで、【Sheet3】シートから【Ａタイプ】シートへコピーします。
Sheet3→一覧表。Ａタイプ→請求書となります。
№1～№45まで繰り返しコピー&ペーストします。
下記の通り№1と№2で作成しましたが、45回繰り返し作成する方法がわかりません。
おわかりの方、ご教示願います。

Worksheets("Sheet3").Range("F4").Copy　　　　’№1
Worksheets("Ａタイプ").Range("E9").PasteSpecial Paste:=xlPasteValues
Worksheets("Sheet3").Range("G4").Copy Worksheets("Ａタイプ").Range("A9:C9")
Worksheets("Sheet3").Range("D4").Copy
Worksheets("Ａタイプ").Range("A11").PasteSpecial Paste:=xlPasteValues
Worksheets("Sheet3").Range("U4").Copy
Worksheets("Ａタイプ").Range("E19").PasteSpecial Paste:=xlPasteValues
Worksheets("Sheet3").Range("K4").Copy
Worksheets("Ａタイプ").Range("F20").PasteSpecial Paste:=xlPasteValues
Worksheets("Sheet3").Range("L4").Copy
Worksheets("Ａタイプ").Range("F21").PasteSpecial Paste:=xlPasteValues
Worksheets("Sheet3").Range("M4").Copy
Worksheets("Ａタイプ").Range("F22").PasteSpecial Paste:=xlPasteValues
Worksheets("Sheet3").Range("N4").Copy
Worksheets("Ａタイプ").Range("F23").PasteSpecial Paste:=xlPasteValues
Worksheets("Sheet3").Range("Z4").Copy
Worksheets("Ａタイプ").Range("E24").PasteSpecial Paste:=xlPasteValues
Worksheets("Sheet3").Range("AB4").Copy
Worksheets("Ａタイプ").Range("E25").PasteSpecial Paste:=xlPasteValues
Worksheets("Sheet3").Range("AC4").Copy
Worksheets("Ａタイプ").Range("G26").PasteSpecial Paste:=xlPasteValues
Worksheets("Sheet3").Range("H4").Copy
Worksheets("Ａタイプ").Range("F27").PasteSpecial Paste:=xlPasteValues
Worksheets("Sheet3").Range("AF4").Copy
Worksheets("Ａタイプ").Range("G28").PasteSpecial Paste:=xlPasteValues
Worksheets("Sheet3").Range("Q4").Copy
Worksheets("Ａタイプ").Range("G29").PasteSpecial Paste:=xlPasteValues
Worksheets("Sheet3").Range("R4").Copy
Worksheets("Ａタイプ").Range("G30").PasteSpecial Paste:=xlPasteValues
Worksheets("Sheet3").Range("AH4").Copy
Worksheets("Ａタイプ").Range("G31").PasteSpecial Paste:=xlPasteValues
Worksheets("Sheet3").Range("AI4").Copy
Worksheets("Ａタイプ").Range("G32").PasteSpecial Paste:=xlPasteValues
Worksheets("Sheet3").Range("AK4").Copy
Worksheets("Ａタイプ").Range("G33").PasteSpecial Paste:=xlPasteValues
Worksheets("Sheet3").Range("AL4").Copy
Worksheets("Ａタイプ").Range("G34").PasteSpecial Paste:=xlPasteValues

Worksheets("Sheet3").Range("F5").Copy　　　’№2
Worksheets("Ａタイプ").Range("E51").PasteSpecial Paste:=xlPasteValues
Worksheets("Sheet3").Range("G5").Copy Worksheets("Ａタイプ").Range("A51:C51")
Worksheets("Sheet3").Range("D5").Copy
Worksheets("Ａタイプ").Range("A53").PasteSpecial Paste:=xlPasteValues
Worksheets("Sheet3").Range("U5").Copy
Worksheets("Ａタイプ").Range("E61").PasteSpecial Paste:=xlPasteValues

いつもお世話になっております。
マクロ初心者です。

2つのシートで、【Sheet3】シートから【Ａタイプ】シートへコピーします。
Sheet3→一覧表。Ａタイプ→請求書となります。
№1～№45まで繰り返しコピー&ペーストします。
下記の通り№1と№2で作成しましたが、45回繰り返し作成する方法がわかりません。
おわかりの方、ご教示願います。

Worksheets("Sheet3").Range("F4").Copy　　　　’№1
Worksheets("Ａタイプ").Range("E9").PasteSpecial Paste:=xlPasteValues
Worksheets("Sheet3").Ra...続きを読む

Aベストアンサー

>下記の部分は全コピーですが、この部分のみが動きません。
>Worksheets("Sheet3").Range("G4").Offset(fromRow).Copy Worksheets("Ａタイプ").Range("A9:C9").Offset(toRow)

こちらの環境では正常に動作しています。
1回目（G4）と2日目（G5)ですが、添付のような結果になります。
これが、望んだ結果だと思いますが、いかがでしょうか。

他の回答も見る

QWorksheet_Change(ByVal Target As Range)の下に複数範囲

始めまして

Private Sub Worksheet_Change(ByVal Target As Range)が全然整理できないので
アドバイスいただけますか
私の能力は
１、N88 BASIC を少しかじりました
2、エクセルで式の入力は少しできます（ロータス123も少しやりました）
3、昔、クイックベーシックはギブアップしました

最近ずっと、知恵袋やここのｇｏｏのエクセルの掲示板から、やりたいことを
可能にしてくれるマクロを探しているのですが、いろいろな表現があって、全然整理できません
例えば下記のマクロなどです（行には自分でメモを書いています）

Private Sub Worksheet_Change(ByVal Target As Range)
　　If Target.Count > 1 Then Exit Sub
　　'複数個所同時入力を拒否する？　　
　　If ActiveSheet.AutoFilterMode Then Exit Sub
　　'AutoFilterModeだったら拒否する
　　If Not Intersect(Target, Range("A1:D4")) Is Nothing Then
　　MsgBox Target.Address　'実際の処理
　　End If
End Sub

さらには
Private Sub Worksheet_Change(ByVal Target As Range)
　　If Not Intersect(Target, Range("A1")) Is Nothing Then
　　'A1の値が変わった
　　　　MsgBox "セル A1 が変更になりました。" '　<--- A1変更時の処理
　　End If
　　If Not Intersect(Target, Range("B1")) Is Nothing Then
　　　　MsgBox "セル B1 が変更になりました。" '　<--- B1変更時の処理
　　End If
　　If Not Intersect(Target, Range("C1")) Is Nothing Then
　　　　MsgBox "セル C1 が変更になりました。" '　<--- C1変更時の処理
　　End If
End Sub

など・・・
他にも
Dim myRng As Range
Dim r As Range
を使いなさいとか

さらには、

Application.EnableEvents = False
Application.EnableEvents = TRUE
を使いなさい

そのマクロ自体が、別のセルを代入したりすると、もうひとつのイベントを発生させてしまい、プロシージャの中で、無限ループに近い形になっています。（ただし、完全な無限ループではないので、1万回程度で止まります。）そこで、その無限ループをとめなくてはならないので、そうした、
Application.EnableEvents = False
ということをします。

などです

===================================================

そこで、さっぱり整理できないので、自分がやりたいことはマクロでどう書けば良いのかを
教えていただければと思います
教えていただいてから、ひとつ、ひとつ検索して勉強します

下記がマクロでやりたいことです

===================================================
入力を監視するセルは下記の範囲で、範囲ごとにやること（処理）は違います
入力は全て整数です（整数が入力されたらその値に応じてマクロで処理します）
入力値のチェックは「入力規則」でやります(IF文書くのがたいへんそうなので）

入力範囲は

Range("B2,D2,H2,J2")
Range("B3,D3,H3,J3")
Range("B5:B100")　
この範囲に値の貼り付けで入力は禁止です、というか、禁止しないと
だめなようです（Worksheet_Changeは）

Range("H5:H100")
この範囲に値の貼り付けで入力は禁止です、というか、禁止しないと
だめなようです（Worksheet_Changeは）

もっと増えるかもしれませんが、その時はなんとか教えていただいた例を参考にやってみます
いきなりの長文の質問ですみません

用語に不慣れで表現が分かりにくかったら指摘してください
よろしくお願いします
エクセルはバージョン２０１３を使っています
最後まで読んでいただきましてありがとうございました

始めまして

Private Sub Worksheet_Change(ByVal Target As Range)が全然整理できないので
アドバイスいただけますか
私の能力は
１、N88 BASIC を少しかじりました
2、エクセルで式の入力は少しできます（ロータス123も少しやりました）
3、昔、クイックベーシックはギブアップしました

最近ずっと、知恵袋やここのｇｏｏのエクセルの掲示板から、やりたいことを
可能にしてくれるマクロを探しているのですが、いろいろな表現があって、全然整理できません
例えば下記のマクロなどです（行には自分...続きを読む

Aベストアンサー

こんにちは。

>Application.EnableEvents = False　の効果を知るには、無限ループになるようなコードが
書けないとだめということですね
>「そんなコードが書けないのだから、効果を実感できるわけがない」という話ですね
>やっと合点しました

私は、そこまで言うつもりはありません。最初は形式的に書いていて、そのうちに分かるようになるということです。実際に、今、「そんなコード」を本当に書ける人がいるのでしょうか？

らしきコードを書いてみましたが、これでも、実証はできません。途中でエラーがでてしまいます。止める場合は、ESCキーを押します。

'A2に値をいれるマクロ
Private Sub Worksheet_Change(ByVal Target As Range)
　If Target.Count > 1 Then Exit Sub
　If Target.Value = "" Then Exit Sub
　If Target.Address(0, 0) <> "A2" Then Exit Sub
'以上除外設定
Application.EnableEvents = False
Target.Value = Target.Value + 1　　'値に値を入れるから保護する必要があります。
Application.EnableEvents = True
If Target.Value > 10 Then Exit Sub　　'再帰になって場合の気休め。実際は働かない
　Exit Sub
End Sub

最近は、PCそのものの性能がよいせいか、忘れてしまう人がいます。無限ループにならないのは、一回のイベントにわずかなタイムラグが出来て、そのタイムラグが、イベントをキャッチする時間の範囲から外れてしまうから、イベントが終了するわけです。

以下の場合は、EnableEvents =False は、不要です。
マクロで値を入れた時に、再イベントが発生するのです。だから、それを防ぐわけです。
-----------------
　If Not Intersect(Target, Range("B2,D2")) Is Nothing Then
MsgBox Target.Value
MsgBox Target.Address
MsgBox Target.Column
MsgBox Target.Row
End If

If Not Intersect(Target, Range("B5:B10,D5:D10")) Is Nothing Then
MsgBox Target.Value
MsgBox Target.Address
MsgBox Target.Column
MsgBox Target.Row
End If
-----------------

>マクロがエラーで止まって、エラーの行が黄色くなって
>コードが示されるようなことでは、逆にマクロなんか使わない方がよさそうです

問題は、そういう所ではないのです。
最初は、プログラムそのものを体得していくことだと思います。
上達のポイントは、なんとか、何年掛かってもよいからと思いつつ、完成を目指すことです。

その都度、覚えた技術を反映しながら、自分のコレクションに加えていきます。

また、ネットで勉強するにしても、なるべく一定の人のものを追いかけて、その人がどう考えて、そのコードになったのか考えながらでもよいと思います。ある程度の内容になると、その人の人柄がコードに出てきます。

マクロで、自分がやりたいことができるようになるには、なかなか時間が掛かります。でも、それ以上に、相手の期待に沿うというのは、もっと大変なことです。

最近、質問した人は、私の説明を読んで、すぐに諦めてしまって質問を閉じてしまいました。こちらも事情があって、その人のために、大掛かりなプログラムを簡単に公開したくはありません。人にやる気を起こさせるのも技術かもしれません。中には、長いコードをみただけで、自分の質問とは違います、と断ってしまう人。せっかく作っても、予定に間に合わなかったので、ボツ。エラー処理したコードは、内容が複雑になっているから、それはダメ。

他人のためにマクロを書くと考えていたら、とてもやっていられるものではありません。

こんにちは。

>Application.EnableEvents = False　の効果を知るには、無限ループになるようなコードが
書けないとだめということですね
>「そんなコードが書けないのだから、効果を実感できるわけがない」という話ですね
>やっと合点しました

私は、そこまで言うつもりはありません。最初は形式的に書いていて、そのうちに分かるようになるということです。実際に、今、「そんなコード」を本当に書ける人がいるのでしょうか？

らしきコードを書いてみましたが、これでも、実証はできません。途中でエラーがで...続きを読む

他の回答も見る

QVBA教えてください

以下のようにテキストファイルに記入されている文字列をエクセルに抽出したいのですが
なかなか思うようにいきません。

＜テキストデータ＞
項 A B C D
1 40
2 30
3 20

＜エクセルに抽出したいデータ＞
1 40
2 30
3 20

どなたかお詳しい方いらっしゃいましたら教えて頂けると幸いです。

Aベストアンサー

大変遅くなりました。以下のような感じはいかがでしょうか？
---------------------------------------------------------------------------------
Sub Sample()
Dim 対象ファイル As String
Dim 行データ As String
Dim 位置 As Long
Dim 対象位置 As Long
Dim 文字数 As Long
Dim 対象 As Boolean
Dim 行 As Long
Dim 比較文字 As String
Dim 数字 As String
対象ファイル = Application.GetOpenFilename("テキストファイル,*.txt")
If 対象ファイル = "False" Then Exit Sub
Open 対象ファイル For Input As #1
Do Until EOF(1)
Line Input #1, 行データ
If 対象 Then
If 対象位置 > Len(行データ) Then 対象 = False
If Mid(行データ, 1, 1) < "0" Then 対象 = False
If Mid(行データ, 1, 1) > "9" Then 対象 = False
If Mid(行データ, 対象位置, 1) < "0" Then 対象 = False
If Mid(行データ, 対象位置, 1) > "9" Then 対象 = False
Else
比較文字 = ""
For 位置 = 1 To Len(行データ)
If Mid(行データ, 位置, 1) <> " " Then
比較文字 = 比較文字 & Mid(行データ, 位置, 1)
If Mid(行データ, 位置, 1) = "D" Then 対象位置 = 位置
End If
Next
End If
If 対象 Then
行 = 行 + 1
数字 = ""
For 位置 = 1 To 対象位置
If Mid(行データ, 位置, 1) < "0" Then Exit For
If Mid(行データ, 位置, 1) > "9" Then Exit For
数字 = 数字 & Mid(行データ, 位置, 1)
Next
Cells(行, 1).Value = 数字
数字 = ""
For 位置 = 対象位置 To Len(行データ)
If Mid(行データ, 位置, 1) < "0" Then Exit For
If Mid(行データ, 位置, 1) > "9" Then Exit For
数字 = 数字 & Mid(行データ, 位置, 1)
Next
Cells(行, 2).Value = 数字
Else
If 比較文字 = "ABCD" Then 対象 = True
For 位置 = 1 To Len(行データ)
If Mid(行データ, 位置, 1) = "D" Then 対象位置 = 位置
Next
End If
Loop
Close #1
End Sub
---------------------------------------------------------------------------------

大変遅くなりました。以下のような感じはいかがでしょうか？
---------------------------------------------------------------------------------
Sub Sample()
Dim 対象ファイル As String
Dim 行データ As String
Dim 位置 As Long
Dim 対象位置 As Long
Dim 文字数 As Long
Dim 対象 As Boolean
Dim 行 As Long
Dim 比較文字 As String
Dim 数字 As String
対象ファイル = Application.GetOpenFilename("テキストファイル,*.txt")
If 対象ファイル = "False" Then Exit Sub
Open 対象ファイル For Inp...続きを読む

他の回答も見る

QExcel 一括並べ替えについて

Ａ30からＹ47の範囲で一括並べ替えをしたいのですが
マクロを組めば画像（矢印下の図表）のように並び替える事は可能でしょうか？

毎回コピーペーストでやっていますが、流石に時間ばかり掛かってしんどいです。

マクロや関数などの知識はありません。

知識が必要でしたら、学習用のサイトなども併せてご紹介をお願いします。

※画像が小さくてわかりにくいかもしれませんがどうぞよろしくお願い致します。

Aベストアンサー

No7です。補足了解しました。
以下のマクロを標準モジュールに登録してください。
-----------------------------------------------
Option Explicit
Public Sub 並べ替え()
Dim sh1 As Worksheet
Dim sh2 As Worksheet
Dim row1 As Long
Dim col1 As Long
Dim row2 As Long
Dim col2 As Long
Set sh1 = Worksheets("Sheet1")
Set sh2 = Worksheets("Sheet2")
sh2.Columns("Z").Clear
row2 = 1
For row1 = 30 To 47
For col1 = 1 To 25
sh2.Cel...続きを読む

他の回答も見る

Qダブルクリックしたセルの４行下の値を得るにはマクロでどう書きますか

よろしくお願いします。
いつもgooの皆さんには大変お世話になっています
エクセルは２０１３です

ダブルクリックしたセルの４行下のセルの値を得るには
MsgBox "４行下の値は"　に続いてどう書けば良いでしょうか

セルの数だけ延々とIfで書く方法しか思いつきません
If Not Intersect(Target, Range("H37,J37,K37,N37")) Is Nothing Then
　Cancel = True
　If Target.Address = "$H$37" Then
　MsgBox "4行下の値は" & Range("H41")
　End If
　If Target.Address = "$J$37" Then
　MsgBo...続きを読む

Aベストアンサー

こんばんは。

簡単に書けば、こういうことなのですが、もっと難しい話なのでしょうか？

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
Cancel = True
MsgBox Target.Offset(4).Value
End Sub

他の回答も見る

Q共有フォルダからのファイル名抽出(VBA)

以前、同様の質問をしたのですが、共有フォルダからファイル名+更新日の抽出する方法をご教示しただいたのですが、30分以上かかっても終わりませんでした・・・・(数が10000以上あるからかと思いますが。。。。)教えていただいたのに申し訳ありません。。。

改めて、更新日は不要にして、ある共有フォルダからファイル名をエクセルに出力する方法を教えていただけませんでしょうか？

B1セルには"ファイル名"というTITELが入っているので
B2セルより下(B2、B3、B4～)にファイル名を記載していくような構文です。
※Dir関数、もしくはそれより早い方法があれば、そちらでも構いません。

よろしくお願いします。

Aベストアンサー

No1です。先のファイルを自分のPCに保存
buf = Dir(ThisWorkbook.Path & "\*.xlsx")
の部分を
buf = Dir(”共有フォルダのパス” & "\*.xlsx")
に変更してみて下さい。

他の回答も見る

QVBAでリストから表を作りやり方を教えてください

VBA初心者です。
標題のやり方を教えてください。
B列に日付、C列に時間、D列にデータがあるリストが有ります（データ数１０００以上）
B列は、最高で14日間、C列は同じ時間が毎日あります。（同じ時間の繰り返し）
同シート別セル（例えばM1）に別の縦軸に時間を、横軸に日付の表を作成し、
その交差する場所にデータが来るようなものをVBAで作れないかと思うのですが、いかがでしょうか
ご存知の方、教えてください
宜しくお願いします

Aベストアンサー

こんばんは！

元データはSheet1にあり、Sheet2のM1セル以降に表示するとします。
画像通り、Sheet1のデータは3行目以降にあるとします。
今回はオートフィルタを使っていますので、Sheet1の2行目は何らかの項目名が入っているという前提です。
画像では項目名が入っていませんが、ダミーでも良いので項目を入れておいてください。

標準モジュールです。

Sub Sample1()
Dim i As Long, k As Long, lastRow As Long
Dim lastCol As Long, wS As Worksheet
Set wS = Worksheets("Sheet2")
lastRow = wS.Cells(Rows.Count, "M").End(xlUp).Row
lastCol = wS.Cells(1, Columns.Count).End(xlToLeft).Column
Application.ScreenUpdating = False
If lastCol > 12 Then
Range(wS.Cells(1, "M"), wS.Cells(lastRow, lastCol)).Clear
End If
With Worksheets("Sheet1")
lastRow = .Cells(Rows.Count, "B").End(xlUp).Row
Range(.Cells(2, "B"), .Cells(lastRow, "B")).AdvancedFilter Action:=xlFilterCopy, copytorange:= _
wS.Range("M1"), unique:=True
For i = 3 To lastRow
If .Cells(i, "B") > .Cells(i - 1, "B") Then Exit For
.Cells(i, "C").Copy wS.Cells(1, Columns.Count).End(xlToLeft).Offset(, 1)
Next i
For k = 2 To wS.Cells(Rows.Count, "M").End(xlUp).Row
.Range("B:B").AutoFilter field:=1, Criteria1:=Format(wS.Cells(k, "M"), "yyyy/m/d") '//←表示形式に注意★//
Range(.Cells(3, "D"), .Cells(lastRow, "D")).SpecialCells(xlCellTypeVisible).Copy
wS.Cells(k, "N").PasteSpecial Paste:=xlPasteAll, Transpose:=True
Next k
.AutoFilterMode = False
wS.Range("M1").CurrentRegion.Columns.AutoFit
wS.Activate
wS.Range("M1").Select
Application.ScreenUpdating = True
MsgBox "完了"
End With
End Sub

※　日付のフィルタはかなり厄介です。
コード内に記載している「★」の行のようにSheet1のB列（日付列）の表示形式は
実際の表示形式に合わせてください。m(_ _)m

こんばんは！

元データはSheet1にあり、Sheet2のM1セル以降に表示するとします。
画像通り、Sheet1のデータは3行目以降にあるとします。
今回はオートフィルタを使っていますので、Sheet1の2行目は何らかの項目名が入っているという前提です。
画像では項目名が入っていませんが、ダミーでも良いので項目を入れておいてください。

標準モジュールです。

Sub Sample1()
Dim i As Long, k As Long, lastRow As Long
Dim lastCol As Long, wS As Worksheet
Set wS = Worksheets("Sheet2")
las...続きを読む

他の回答も見る

Q【Excel】右上がりの罫線を引く

セル「M10」に”無”と入力されると、セル「Ｍ11」のセルに右上がりの罫線を引きたいです。
どうぞよろしくお願いいたします。

Aベストアンサー

こんにちは！

VBAになりますが、一例です。
シートモジュールにしてください。

Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Address = "$M$10" Then
With Range("M11").Borders(xlDiagonalUp)
If Target = "無" Then
.LineStyle = xlContinuous
Else
.LineStyle = xlNone
End If
End With
End If
End Sub

※　対象セルはM10だけでよいのですよね？m(_ _)m