Sheet1およびSheet2というシートを含む新しいワークブックを作成します（コードの定数を変更することで名前を変更できます）メインモジュールと3つのクラスモジュールを追加します（VBAエディターで[挿入]> [モジュール]および[クラスモジュールの挿入]をクリックし、Alt F11をクリックして開始します）名前を変更します次のようなクラスモジュール：請求書、アイテム、注文
次のコードをクラスモジュールBillに追加します
Option Explicit
Public ID As String
Public ItemName As String
クラスモジュールアイテムに以下を追加します
Option Explicit
Public Name As String
Public ColumnNumber As Long
Private Sub Class_Initialize()
ColumnNumber = 0
End Sub
次のコードをクラスモジュールの順序に追加します
Option Explicit
Public Bills As Collection
Public ID As String
Public Sub AddBill(BillID As String, ItemName As String)
Dim B As Bill
Set B = New Bill
B.ID = BillID
B.ItemName = ItemName
Bills.Add B
End Sub
Private Sub Class_Initialize()
Set Bills = New Collection
End Sub
次のコードをメインのムードルに追加します
Option Explicit
Const ORDER_TXT As String = "Order No." 'text in the header cell for order number column
Const INPUT_SHEET_NAME As String = "Sheet1"
Const OUTPUT_SHEET_NAME As String = "Sheet2"
Const FIRST_OUTPUT_COL As Long = 2
Const FIRST_OUTPUT_ROW As Long = 2
Dim Orders As Collection
Dim Items As Collection
Sub process_data()
Dim sh As Worksheet
Dim HeaderRow As Long
Dim HeaderCol As Long
Dim CurRow As Long
Dim CurOrder As Order
Dim CurItemCol As Long
Dim CurItem As Item
Dim CurBill As Bill
'Get Info from input sheet
CurItemCol = FIRST_OUTPUT_COL + 1
HeaderRow = 1
HeaderCol = 1
Set Orders = New Collection
Set Items = New Collection
If FindCell(ORDER_TXT, INPUT_SHEET_NAME, sh, HeaderRow, HeaderCol, False) Then
CurRow = HeaderRow + 1
Do While sh.Cells(CurRow, HeaderCol).Value <> ""
Set CurOrder = GetOrder(sh.Cells(CurRow, HeaderCol).Value)
If sh.Cells(CurRow, HeaderCol + 1).Value <> "" Then
If sh.Cells(CurRow, HeaderCol + 2).Value <> "" Then
Set CurItem = GetItem(sh.Cells(CurRow, HeaderCol + 2).Value)
If CurItem.ColumnNumber = 0 Then
'its a new item
CurItem.ColumnNumber = CurItemCol
CurItemCol = CurItemCol + 1
End If
'now add this bill to the order
Call CurOrder.AddBill(sh.Cells(CurRow, HeaderCol + 1).Value, CurItem.Name)
End If 'could add else with error message here
End If
CurRow = CurRow + 1
Loop
'now put data on output sheet
'find output sheet
For Each sh In ThisWorkbook.Sheets
If sh.Name = OUTPUT_SHEET_NAME Then Exit For
Next
'Add check here that we found the sheet
CurRow = FIRST_OUTPUT_ROW
'write headers
sh.Cells(CurRow, FIRST_OUTPUT_COL).Value = ORDER_TXT
For Each CurItem In Items
sh.Cells(CurRow, CurItem.ColumnNumber).Value = CurItem.Name
Next
'Write Orders
For Each CurOrder In Orders
CurRow = CurRow + 1
sh.Cells(CurRow, FIRST_OUTPUT_COL).Value = CurOrder.ID
For Each CurBill In CurOrder.Bills
sh.Cells(CurRow, GetColumnNumber(CurBill.ItemName)).Value = CurBill.ID
Next
Next
End If
End Sub
Function GetColumnNumber(ItemName As String) As Long
Dim I As Item
GetColumnNumber = 1 'default value
For Each I In Items
If I.Name = ItemName Then
GetColumnNumber = I.ColumnNumber
Exit Function
End If
Next
End Function
Function GetOrder(OrderID As String) As Order
Dim O As Order
For Each O In Orders
If O.ID = OrderID Then
Set GetOrder = O
Exit Function
End If
Next
'if we get here then we didn't find a matching order
Set O = New Order
Orders.Add O
O.ID = OrderID
Set GetOrder = O
End Function
Function GetItem(ItemName As String) As Item
Dim I As Item
For Each I In Items
If I.Name = ItemName Then
Set GetItem = I
Exit Function
End If
Next
'if we get here then we didn't find a matching Item
Set I = New Item
Items.Add I
I.Name = ItemName
Set GetItem = I
End Function
Function FindCell(CellText As String, SheetName As String, sh As Worksheet, row As Long, col As Long, SearchCaseSense As Boolean) As Boolean
Const GapLimit As Long = 10
'searches the named sheet column at a time, starting with the column and row specified in row and col
'gives up on each row if it finds GapLimit empty cells
'gives up on search if it finds do data un GapLimit columns
Dim RowFails As Long
Dim ColFails As Long
Dim firstrow As Long
FindCell = False
firstrow = row
ColFails = 0
RowFails = 0
'find sheet
For Each sh In ThisWorkbook.Sheets
If sh.Name = SheetName Then Exit For
Next
If sh.Name = SheetName Then
Do 'search columns
ColFails = ColFails + 1
Do 'search column
If sh.Cells(row, col).Value = "" Then
RowFails = RowFails + 1
Else
If ((sh.Cells(row, col).Value = CellText And SearchCaseSense) Or (UCase(sh.Cells(row, col).Value) = UCase(CellText) And (Not SearchCaseSense))) Then
FindCell = True
Exit Function
End If
RowFails = 0
ColFails = 0
End If
row = row + 1
Loop While RowFails <= GapLimit
col = col + 1
row = firstrow
RowFails = 0
Loop While ColFails < GapLimit
End If
End Function
ルーチンprocess_dataを実行します（ExcelのAlt F8）
このプログラムは、同じ注文の同じアイテム（コーヒーなど）の複数の請求書を考慮していません。1つの請求書のみが表示されます。その状況をどのように処理したいかわかりませんでした。コードを無効なデータに対して堅牢にするために、コードのチェックとエラー処理ルーチンが必要です。ヒントとしていくつかのコメントを追加しました。
お役に立てれば