【至急】VBAについて教えてください。添付の画像のような表を作りたいです。

Question

はじめまして、以下のような表を作りたいです。
まずはじめに添付の画像の表があり、マクロを実行することで追加で添付した画像のような表にしたいです。
VBAは初めてで、しかも時間もないので焦っています。
よろしくお願い致します。

tom04 · Accepted Answer

最終確認です。

①　三つのブックは同じフォルダ内に保存している
②　参照元ファイル名は「Book1」、表示したいブックのファイル名は「Book2」とし
両ブックの拡張子は「xlsx」とする
③　元データは　Book1　の　Sheet1　にあり、表示するのは　Book2　の　Sheet1　とする
④　表示するデータは項目行を入れて3行のみ（C列が「良品」以外はすべて「不良品」の行にまとめる）
以上の前提条件です。

別ブック参照するときは気を付けなければならないコトが多くあります。
ブック名とシート名
これは必須です。これらを指定してやらないとちゃんと動かないコトが多いです。

↓のコードをマクロ記載ブック（三つ目のブック）の標準モジュールにしてみてください。

Sub Sample3()
　Dim myPath As String, fN As String
　Dim i As Long, k As Long, lastRow As Long, myRow As Long
　Dim wB1 As Workbook, wB2 As Workbook, wS As Worksheet
　Dim c As Range, myFlg As Boolean
 
　　Application.ScreenUpdating = False
　　　'//▼ここからブックを開く操作//
　　　myPath = ThisWorkbook.Path & "\"
　　　fN = "Book1.xlsx"
　　　　If Workbooks.Count > 1 Then
　　　　　For k = 2 To Workbooks.Count
　　　　　　If Workbooks(k).Name = fN Then
　　　　　　　myFlg = True
　　　　　　End If
　　　　　Next k
　　　　End If
　　　If Workbooks.Count = 1 Or myFlg = False Then
　　　　Workbooks.Open myPath & fN
　　　End If
　　　　Set wB1 = Workbooks(fN)
　　　　Set wS = wB1.Worksheets("Sheet1")
　　　　myFlg = False
     
　　　fN = "Book2.xlsx"
　　　　For k = 2 To Workbooks.Count
　　　　　If Workbooks(k).Name = fN Then
　　　　　　myFlg = True
　　　　　End If
　　　　Next k
　　　　If myFlg = False Then
　　　　　Workbooks.Open myPath & fN
　　　　End If
　　　　　Set wB2 = Workbooks(fN)
　　　'//▲ココまで//
    
　　　'//▼ココから本格的な操作//
　　　With wB2.Worksheets("Sheet1")
　　　　.Cells.ClearContents
　　　　wS.Range("A:A").AdvancedFilter Action:=xlFilterCopy, copytorange:=.Range("A1"), unique:=True
　　　　lastRow = .Cells(Rows.Count, "A").End(xlUp).Row
　　　　　Range(.Cells(1, "B"), .Cells(1, lastRow)).Value = _
　　　　　　Application.Transpose(Range(.Cells(2, "A"), .Cells(lastRow, "A")).Value)
　　　　　.Range("A:A").ClearContents
　　　　　.Range("A1") = wS.Range("C1")
　　　　　.Range("A2") = "良品"
　　　　　.Range("A3") = "不用品"
　　　　　　For i = 2 To wS.Cells(Rows.Count, "A").End(xlUp).Row
　　　　　　　Set c = .Rows(1).Find(what:=wS.Cells(i, "A"), LookIn:=xlValues, lookat:=xlWhole)
　　　　　　　　If wS.Cells(i, "C") = "良品" Then
　　　　　　　　　myRow = 2
　　　　　　　　Else
　　　　　　　　　myRow = 3
　　　　　　　　End If
　　　　　　　　With .Cells(myRow, c.Column)
　　　　　　　　　If .Value = "" Then
　　　　　　　　　　.Value = wS.Cells(i, "B")
　　　　　　　　　Else
　　　　　　　　　　.Value = .Value & "," & wS.Cells(i, "B")
　　　　　　　　　End If
　　　　　　　　End With
　　　　　　Next i
　　　　　.Columns.AutoFit
　　　　　.Activate
　　　End With
　　　　Application.ScreenUpdating = True
　　　　MsgBox "完了"
End Sub

※　上記コードをコピー＆ペーストした後に
マクロ有効ブックとして、一旦名前を付けて保存（二つのブックと同じファイルに！）し
新たに開いてマクロを実行してみてください。

※　二つのブックは開いたままにしていますが、
当然上書き保存して閉じることもマクロで可能です。m(_ _)m

tom04 · Answer

こんばんは！

元データはSheet1にあり、Sheet2に表示するとします。
尚、1行目は項目行でデータはA列2行目以降にあるという前提です。
一例です。
標準モジュールにしてください。

Sub Sample1()
　Dim i As Long, lastRow As Long
　Dim c As Range, r As Range
　Dim wS As Worksheet
　　Set wS = Worksheets("Sheet1")
　　　With Worksheets("Sheet2")
　　　　Application.ScreenUpdating = False
　　　　　.Cells.ClearContents
　　　　　wS.Range("A:A").AdvancedFilter Action:=xlFilterCopy, copytorange:=.Range("A1"), unique:=True
　　　　　　lastRow = .Cells(Rows.Count, "A").End(xlUp).Row
　　　　　　Range(.Cells(1, "B"), .Cells(1, lastRow)).Value = _
　　　　　　　Application.Transpose(Range(.Cells(2, "A"), .Cells(lastRow, "A")).Value)
　　　　　　Range(.Cells(2, "A"), .Cells(lastRow, "A")).ClearContents
　　　　　　.Range("A2") = "良品"
　　　　　　.Range("A3") = "不良品"
　　　　　　　For i = 2 To wS.Cells(Rows.Count, "A").End(xlUp).Row
　　　　　　　　Set r = .Rows(1).Find(what:=wS.Cells(i, "A"), LookIn:=xlValues, lookat:=xlWhole)
　　　　　　　　Set c = .Range("A:A").Find(what:=wS.Cells(i, "C"), LookIn:=xlValues, lookat:=xlWhole)
　　　　　　　　　With .Cells(c.Row, r.Column)
　　　　　　　　　　If .Value = "" Then
　　　　　　　　　　　.Value = wS.Cells(i, "B")
　　　　　　　　　　Else
　　　　　　　　　　　.Value = .Value & "," & wS.Cells(i, "B")
　　　　　　　　　　End If
　　　　　　　　　End With
　　　　　　　Next i
　　　　　　.Columns.AutoFit
　　　　Application.ScreenUpdating = True
　　　　　.Activate
　　　End With
　　　　MsgBox "完了"
End Sub

こんな感じではどうでしょうか？m(_ _)m

tom04 · Answer

No.1です。

二番目の補足のエラーに関してですが・・・
もしかしてシートモジュールにしていませんか？
シートモジュールで別シートのデータの消去などを行うとエラーになる場合があります。
標準モジュールであればちゃんと動作すると思うのですが。
もしくはシート名が違うとか？

そして、最初の補足の件ですが
異なるブックが三つあり、一つのブックのマクロで他の二つのブックの操作だけをしたい！っていうコトでしょうか？

通常、そのような場合は一つのブックのマクロ（たとえばデータを表示するブック、画像では下側のブックのマクロ）で
他のブックを開く　→　操作　→　他のブックを閉じる！
といった手順にするのが一般的だと思います。
すなわちわざわざ行いたい操作を記載したマクロだけのブックを作る必要はないと思うのですが。

どうしてもそのようにしたいのであれば、当然可能です。
ただ、今はじっくり考える時間がないので、とりあえずこの程度で・・・m(_ _)m

tom04 · Answer

続けてお邪魔します。
どうも失礼しました。
補足の
＞不良品以外にも「廃棄」・・・
を見逃していました。

とりあえずSheet1のC列のデータが何種類あっても対応できる方法にしてみました。
少し手を加えるだけで大丈夫なので、これに関してはすぐに回答はできます。

前回のコードを消去し、↓のコードに変更してみてください。
（もちろん、標準モジュールです）

Sub Sample2()
　Dim i As Long, lastRow As Long
　Dim c As Range, r As Range
　Dim wS As Worksheet
　　Set wS = Worksheets("Sheet1")
　　　With Worksheets("Sheet2")
　　　　Application.ScreenUpdating = False
　　　　　.Cells.ClearContents
　　　　　wS.Range("A:A").AdvancedFilter Action:=xlFilterCopy, copytorange:=.Range("A1"), unique:=True
　　　　　lastRow = .Cells(Rows.Count, "A").End(xlUp).Row
　　　　　　Range(.Cells(1, "B"), .Cells(1, lastRow)).Value = _
　　　　　　　Application.Transpose(Range(.Cells(2, "A"), .Cells(lastRow, "A")).Value)
　　　　　　Range(.Cells(1, "A"), .Cells(lastRow, "A")).ClearContents   '//★//
　　　　　　wS.Range("C:C").AdvancedFilter Action:=xlFilterCopy, copytorange:=.Range("A1"), unique:=True '//★//
　　　　　　　For i = 2 To wS.Cells(Rows.Count, "A").End(xlUp).Row
　　　　　　　　Set r = .Rows(1).Find(what:=wS.Cells(i, "A"), LookIn:=xlValues, lookat:=xlWhole)
　　　　　　　　Set c = .Range("A:A").Find(what:=wS.Cells(i, "C"), LookIn:=xlValues, lookat:=xlWhole)
　　　　　　　　　With .Cells(c.Row, r.Column)
　　　　　　　　　　If .Value = "" Then
　　　　　　　　　　　.Value = wS.Cells(i, "B")
　　　　　　　　　　Else
　　　　　　　　　　　.Value = .Value & "," & wS.Cells(i, "B")
　　　　　　　　　　End If
　　　　　　　　　End With
　　　　　　　Next i
　　　　　　.Columns.AutoFit
　　　　Application.ScreenUpdating = True
　　　　　.Activate
　　　End With
　　　　MsgBox "完了"
End Sub

※　コード内の「★」の行が変わっているだけです。m(_ _)m

【至急】VBAについて教えてください。添付の画像のような表を作りたいです。

こんばんは！

No.1です。

続けてお邪魔します。

最終確認です。

似たような質問が見つかりました

関連するカテゴリからQ&Aを探す

デイリーランキングこのカテゴリの人気デイリーQ&Aランキング

マンスリーランキングこのカテゴリの人気マンスリーQ&Aランキング