Question

我有一个要求，即一个ID下有一组值（这个ID对于每个组都是唯一的）。我希望通过excel VBA为每个值创建新列，将组的值复制到新工作表。说，这是我的主要表格

ORDER NO.    BILL  ITEM
============================ 
12345        100       Pizza
12345        200       Choco
12345        300       Coffee
12345        400       Pizza1
12345        500       Drink
12456        600       Pizza
12456        700       Choco
12456        800       Pizza1
12360        900       Pizza
12360        1000      Choco
12360        1100      Coffee

我希望o / p如下所示：

ORDER NO. PIZZA PIZZA1 CHOCO COFFEE COFFEE1 DRINK 
===============================================================  
12345     100   400    200   300            500  
12456     600   800    700    
12360     900         1000   1100

我希望主表中存在的值应该复制到新工作簿中的相应列，例如'PIZZA'值应该复制到新工作簿中，而不是正确的'ORDER NO'。如在主要表格中。需要一个excel VBA才能做到这一点。亲切的帮助。

Answer 1

听起来像是一个数据透视表的工作。将Order No放在Row部分，Column部分中的Item和Values部分中的Bill。

Answer 2

使用名为Sheet1和Sheet2的工作表获取新工作簿（可以通过更改代码中的常量来更改名称）添加一个主模块和3个类模块（在VBA编辑器中单击Inser＆gt;模块和插入类模块，Alt F11开始）按如下方式重命名类模块：Bill，Item和Order

将以下代码添加到类模块Bill

Option Explicit

Public ID As String
Public ItemName As String

将以下内容添加到Class模块Item

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）

该程序没有考虑同一订单上具有相同项目（例如咖啡）的多个账单，只会出现一个账单，我不知道您想如何处理这种情况。代码需要检查和错误处理例程，以使其对无效数据具有健壮性，我添加了一些注释作为提示。

希望这有帮助

通过EXCEL VBA为每个值创建新列，将值与ID匹配的列复制到新工作表

2 个答案: