[英]Copying values from one column that matches a ID to a new sheet by creating new columns for each values through EXCEL VBA
I have a requirement where there is a group of values under one ID(this ID is unique for each group). 我有一个ID下有一组值的要求(此ID对于每个组都是唯一的)。 I want the values of the group to be copied to a new sheet by creating new columns for each values through excel VBA.
我希望通过excel VBA为每个值创建新列,从而将组的值复制到新表中。 say, this is my main sheet
说,这是我的主要工作表
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
I want the o/p like the one below: 我希望o / p如下所示:
ORDER NO. PIZZA PIZZA1 CHOCO COFFEE COFFEE1 DRINK =============================================================== 12345 100 400 200 300 500 12456 600 800 700 12360 900 1000 1100
I would like that the values present in the main sheet should be copied to a new workbook to the corresponding columns like 'PIZZA' values should be copied to a new workbook against the correct 'ORDER NO.' 我希望将主工作表中存在的值复制到新工作簿中的相应列中,例如“ PIZZA”值应针对正确的“订单号”复制到新工作簿中。 as in main sheet.
如在主表中。 Need a excel VBA to do this.Kindly help.
需要Excel VBA才能执行此操作。请提供帮助。
Sounds like a job for a Pivot Table. 听起来像是数据透视表的工作。 Put the Order No in the Row section, the Item in the Column section, and the Bill in the Values section.
将“订单号”放在“行”部分,将“项目”放在“列”部分,将“帐单”放在“值”部分。
Take a new workbook with sheets called Sheet1 and Sheet2 (names can be changed by changing constants in the code) Add a main module and 3 Class modules (click Inser > Module and Insert Class Module in the VBA editor, Alt F11 to start) Rename the class modules as follows: Bill, Item and Order 新建一个包含Sheet1和Sheet2的工作表的工作簿(可通过更改代码中的常量来更改名称)添加一个主模块和3个Class模块(在VBA编辑器中单击Inser> Module and Insert Class Module,单击Alt F11以开始)类模块如下:帐单,项目和订单
Add the following code to Class module Bill 将以下代码添加到Class模块Bill
Option Explicit
Public ID As String
Public ItemName As String
Add the folloing to Class module Item 将以下内容添加到“类”模块中
Option Explicit
Public Name As String
Public ColumnNumber As Long
Private Sub Class_Initialize()
ColumnNumber = 0
End Sub
Add the following code to Class Module Order 将以下代码添加到“类模块顺序”中
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
Add the following code to your main moodule 将以下代码添加到您的主要情绪中
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
Run the routine process_data (Alt F8 from excel) 运行例程process_data(来自Excel的Alt F8)
This program does not take account of multiple bills with the same items (eg Coffee) on the same order, only one bill will appear, I did not know how you wanted to handle that situation. 该程序不考虑在同一订单上具有相同项目(例如咖啡)的多个账单,只会出现一个账单,我不知道您想如何处理这种情况。 The code needs checking and error handling routines to make it robust against invalid data, I have added a few comments as hints.
该代码需要检查和错误处理例程,以使其对无效数据具有鲁棒性,我添加了一些注释作为提示。
Hope this helps 希望这可以帮助
声明:本站的技术帖子网页,遵循CC BY-SA 4.0协议,如果您需要转载,请注明本站网址或者原文地址。任何问题请咨询:yoyou2525@163.com.