vba構文 作成依頼

質問

添付画像左のようなsheet1のデータベースを基に新たにシートを追加して、そのシートへ添付画像右のような集計結果をvbaによって作成したいです。
ご教授宜しくお願い致します。

回答No.1

eden3616 · ベストアンサー

Alt+F11よりVBEを開き、挿入から標準モジュールを挿入
最下のVBAコードを貼り付けて右上の「×」でVBEを閉じる
集計対象のシート（Sheet1）を表示した状態でAlt+F8より「Sample」マクロを選び実行

シートを最後に新規作成して結果を表示します。
集計後の並びは、1項目目の出現順になります。
（セルのコピーでないため、罫線等は移動しません）

仕様変更・不具合等あれば補足願います。

■VBAコード

Sub Sample()
Dim myDat As Variant, tarSheet As Worksheet, i As Long, myRow As Long
myDat = Range(Range("A1"), Cells(Cells(Rows.Count, "A").End(xlUp).Row, "D"))
With ActiveWorkbook.Sheets.Add(After:=Worksheets(Worksheets.Count))
　　.Range("A1:D1") = myDat
　　For i = 2 To UBound(myDat, 1)
　　　　myRow = CStr(sh(myDat(i, 1), .Columns("A")))
　　　　If myRow = 0 Then
　　　　　　.Cells(Rows.Count, "A").End(xlUp).Offset(1, 0).Resize(1, 4) = _
　　　　　　　　Array(myDat(i, 1), myDat(i, 2), myDat(i, 3), myDat(i, 4))
　　　　Else
　　　　　　.Cells(myRow, Columns.Count).End(xlToLeft).Offset(0, 1).Resize(1, 3) = _
　　　　　　　　Array(myDat(i, 2), myDat(i, 3), myDat(i, 4))
　　　　End If
　　Next i
End With
End Sub
Private Function sh(key As Variant, tar As Range) As Long
　　On Error GoTo era
　　sh = Application.WorksheetFunction.Match(key, tar, 0)
　　Exit Function
era:
　　sh = 0
End Function

お礼

回答ありがとうございます。
動作完璧でした。
本当に助かりました。
また何かありましたら宜しくお願い致しますm(_ _)m