用于数据集的Excel VBAmacros
我需要从数据集matrix中创build一个csv文件，其中我有材料作为行，人作为列和数量的交集产品。 这里是这个数据集的例子（Order id＃1000）：
Materials Person1 Person2 563718 20 40 837563 15 35 作为第一个操作，我必须在附加的表单上将这个数据集转换为线性结构：
Orderid Material Person Qty 1000 563718 Person1 20 1000 837563 Person1 15 1000 563718 Person2 40 1000 837563 Person2 35
而从这个线性结构，我必须生成一个csv文件与订单的另一个系统基于上面的列表中的唯一的人。 每个订单应该有一个标题行和细节，根据他/她订购的材料的数量。 一般结构如下：
H,1000-1,OUT,20160830,Person1 l,1000-1,1,563718,20,EA l,1000-1,2,837563,15,EA H,1000-2,OUT,20160830,Person2 l,1000-2,1,563718,40,EA l,1000-2,2,837563,15,EA
其中“H”表示标题行，“1000-1” – 全球订单1000的第一个子订单，“20160830”请求交货date，“l” – 行行，“1” – 行号，“EA” – 测量单位。
这里有一个macros，可以帮你实现。 它把你的第一个表中的数据组织起来，这样你的date在像列（person1和person2）被分成不同的行：
该脚本假设您的固定列位于左侧，而要合并的列（并分成多行）在右侧。 我希望这有帮助！
Option Explicit Sub MatrixConverter2_3() ' Macro created 11/16/2005 by Peter T Oboyski (updated 8/24/2006) ' ' *** Substantial changes made by Chris Brackett (updated 8/3/2016) *** ' ' You are welcome to redistribute this macro, but if you make substantial ' changes to it, please indicate so in this section along with your name. ' This Macro converts matrix-type spreadsheets (eg. plot x species data) into column data ' The new (converted) spreadsheet name is "DB of 'name of active spreadsheet'" ' The conversion allows for multiple header rows and columns. '-------------------------------------------------- ' This section declares variables for use in the script Dim book, head, cels, mtrx, dbase, v, UserReady, columnsToCombine, RowName, DefaultRowName, DefaultColName1, DefaultColName2, ColName As String Dim defaultHeaderRows, defaultHeaderColumns, c, r, selectionCols, ro, col, newro, newcol, rotot, coltot, all, rowz, colz, tot As Long Dim headers(100) As Variant Dim dun As Boolean '-------------------------------------------------- ' This section sets the script defaults defaultHeaderRows = 1 defaultHeaderColumns = 2 DefaultRowName = "Activity" '-------------------------------------------------- ' This section asks about data types, row headers, and column headers UserReady = MsgBox("Have you selected the entire data set (not the column headers) to be converted?", vbYesNoCancel) If UserReady = vbNo Or UserReady = vbCancel Then GoTo EndMatrixMacro all = MsgBox("Exclude zeros and empty cells?", vbYesNoCancel) If all = vbCancel Then GoTo EndMatrixMacro ' UN-COMMENT THIS SECTION TO ALLOW FOR MULTIPLE HEADER ROWS rowz = 1 ' rowz = InputBox("How many HEADER ROWS?" & vbNewLine & vbNewLine & "(Usually 1)", "Header Rows & Columns", defaultHeaderRows) ' If rowz = vbNullString Then GoTo EndMatrixMacro colz = InputBox("How many HEADER COLUMNS?" & vbNewLine & vbNewLine & "(These are the columns on the left side of your data set to preserve as is.)", "Header Rows & Columns", defaultHeaderColumns) If colz = vbNullString Then GoTo EndMatrixMacro '-------------------------------------------------- ' This section allows the user to provide field (column) names for the new spreadsheet selectionCols = Selection.Columns.Count ' get the number of columns in the selection For r = 1 To selectionCols headers(r) = Selection.Cells(1, r).Offset(rowOffset:=-1, columnOffset:=0).Value ' save the column headers to use as defaults for user provided names Next r colz = colz * 1 columnsToCombine = "'" & Selection.Cells(1, colz + 1).Offset(rowOffset:=-1, columnOffset:=0).Value & "' to '" & Selection.Cells(1, selectionCols).Offset(rowOffset:=-1, columnOffset:=0).Value & "'" Dim Arr(20) As Variant newcol = 1 For r = 1 To rowz If r = 1 Then RowName = DefaultRowName Arr(newcol) = InputBox("Field name for the fields/columns to be combined" & vbNewLine & vbNewLine & columnsToCombine, , RowName) If Arr(newcol) = vbNullString Then GoTo EndMatrixMacro newcol = newcol + 1 Next For c = 1 To colz ColName = headers(c) Arr(newcol) = InputBox("Field name for column " & c, , ColName) If Arr(newcol) = vbNullString Then GoTo EndMatrixMacro newcol = newcol + 1 Next Arr(newcol) = "Data" v = newcol '-------------------------------------------------- ' This section creates the new spreadsheet, names it, and color codes the new worksheet tab mtrx = ActiveSheet.Name Sheets.Add After:=ActiveSheet dbase = "DB of " & mtrx '-------------------------------------------------- ' If the proposed worksheet name is longer than 28 characters, truncate it to 29 characters. If Len(dbase) > 28 Then dbase = Left(dbase, 28) '-------------------------------------------------- ' This section checks if the proposed worksheet name ' already exists and appends adds a sequential number ' to the name Dim sheetExists As Variant Dim Sheet As Worksheet Dim iName As Integer Dim dbaseOld As String dbaseOld = dbase ' save the original proposed name of the new worksheet iName = 0 sheetExists = False CheckWorksheetNames: For Each Sheet In Worksheets ' loop through every worksheet in the workbook If dbase = Sheet.Name Then sheetExists = True iName = iName + 1 dbase = Left(dbase, Len(dbase) - 1) & " " & iName GoTo CheckWorksheetNames ' Exit For End If Next Sheet '-------------------------------------------------- ' This section notify the user if the proposed ' worksheet name is already being used and the new ' worksheet was given an alternate name If sheetExists = True Then MsgBox "The worksheet '" & dbaseOld & "' already exists. Renaming to '" & dbase & "'." End If '-------------------------------------------------- ' This section creates and names a new worksheet On Error Resume Next 'Ignore errors If Sheets("" & Range(dbase) & "") Is Nothing Then ' If the worksheet name doesn't exist ActiveSheet.Name = dbase ' Rename newly created worksheet Else MsgBox "Cannot name the worksheet '" & dbase & "'. A worksheet with that name already exists." GoTo EndMatrixMacro End If On Error GoTo 0 ' Resume normal error handling Sheets(dbase).Tab.ColorIndex = 41 ' color the worksheet tab '-------------------------------------------------- ' This section turns off screen and calculation updates so that the script ' can run faster. Updates are turned back on at the end of the script. Application.Calculation = xlCalculationManual Application.ScreenUpdating = False '-------------------------------------------------- 'This section determines how many rows and columns the matrix has dun = False rotot = rowz + 1 Do If (Sheets(mtrx).Cells(rotot, 1) > 0) Then rotot = rotot + 1 Else dun = True End If Loop Until dun rotot = rotot - 1 dun = False coltot = colz + 1 Do If (Sheets(mtrx).Cells(1, coltot) > 0) Then coltot = coltot + 1 Else dun = True End If Loop Until dun coltot = coltot - 1 '-------------------------------------------------- 'This section writes the new field names to the new spreadsheet For newcol = 1 To v Sheets(dbase).Cells(1, newcol) = Arr(newcol) Next '-------------------------------------------------- 'This section actually does the conversion tot = 0 newro = 2 For col = (colz + 1) To coltot For ro = (rowz + 1) To rotot 'the next line determines if data are nonzero If ((Sheets(mtrx).Cells(ro, col) <> 0) Or (all <> 6)) Then 'DCB modified ">0" to be "<>0" to exclude blank and zero cells tot = tot + 1 newcol = 1 For r = 1 To rowz 'the next line copies the row headers Sheets(dbase).Cells(newro, newcol) = Sheets(mtrx).Cells(r, col) newcol = newcol + 1 Next For c = 1 To colz 'the next line copies the column headers Sheets(dbase).Cells(newro, newcol) = Sheets(mtrx).Cells(ro, c) newcol = newcol + 1 Next 'the next line copies the data Sheets(dbase).Cells(newro, newcol) = Sheets(mtrx).Cells(ro, col) newro = newro + 1 End If Next Next '-------------------------------------------------- 'This section displays a message box with information about the conversion book = "Original matrix = " & ActiveWorkbook.Name & ": " & mtrx & Chr(10) head = "Matrix with " & rowz & " row headers and " & colz & " column headers" & Chr(10) cels = tot & " cells of " & ((rotot - rowz) * (coltot - colz)) & " with data" '-------------------------------------------------- ' This section turns screen and calculation updates back ON. Application.Calculation = xlCalculationAutomatic Application.ScreenUpdating = True MsgBox (book & head & cels) '-------------------------------------------------- ' This is an end point for the macro EndMatrixMacro: End Sub
感谢@ChrisB为您的答案。 其实我决定以自己的方式做，这是我做的主要步骤：
- 我创build了一个Excel文件，其中有几个button，我在子程序下面分配了这些button。 另外我添加了一些参数，用户可以修改（OrderId，Delivery Date和WH id）。
- 我创build了一个子程序ReadData（），它清除原始文件中的Sheet“DATA”，并在数据文件中逐列读取后生成一个线性数据集，其中包含“DATA”表中的所有必需字段。
- 之后，我只是写“数据”表到外部csv文件。
最终的代码如下所示：
Global Const DAODBEngine = "DAO.DBEngine.36" Global intColBeg As Integer 'Column Index with Data set to analyze Global intRowBeg As Integer 'Row Index with Data set to analyze Sub FileOpen() Dim filePath As String filePath = Application.GetOpenFilename() If filePath = "False" Then Exit Sub ThisWorkbook.Sheets("BASE").Cells(4, 3) = filePath End Sub Sub ClearData() ' Check if DATA Sheet exists If Evaluate("ISREF('" & "DATA" & "'!A1)") Then Application.DisplayAlerts = False ThisWorkbook.Sheets("DATA").Delete Application.DisplayAlerts = True End If Dim sheet As Worksheet ThisWorkbook.Sheets.Add(After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count)).Name = "DATA" End Sub ' This function reads data and adds it to DATA Sheet Sub ReadData() Dim i As Integer, l As Integer Dim intColumn As Integer, intRow As Integer Dim intAddRow As Integer Dim wbCopyFrom As Workbook Dim wbCopyTo As Workbook Dim wsCopyFrom As Worksheet Dim wsCopyTo As Worksheet Dim dataLoc As String, wbLoc As String Dim mandant As String Dim orderId As String Dim orderNum As Integer Dim shipDate As Date dataLoc = Trim(ThisWorkbook.Sheets("BASE").Cells(4, 3).Text) Set wbCopyFrom = Workbooks.Open(dataLoc) Set wsCopyFrom = wbCopyFrom.Worksheets(1) ThisWorkbook.Activate Call ClearData ' Clears all the data on DATA Sheet Set wbCopyTo = ThisWorkbook Set wsCopyTo = wbCopyTo.Sheets("DATA") wbCopyTo.Activate mandant = wbCopyTo.Sheets("BASE").Cells(11, 3).Text orderId = wbCopyTo.Sheets("BASE").Cells(7, 3).Text shipDate = wbCopyTo.Sheets("BASE").Cells(9, 3).Text ' Initial upper left row/column where matrix data begins intColBeg = 4 intRowBeg = 4 intColumn = intColBeg intRow = intRowBeg intAddRow = 1 ' We will add data from this row orderNum = 1 While Trim(wsCopyFrom.Cells(intRowBeg - 1, intColumn).Text) <> "" ' Header of an Order wsCopyTo.Cells(intAddRow, 1) = "H;OUT;" & mandant & ";" & orderId & "/" & orderNum & ";" & _ ";;" & Mid(shipDate, 7, 4) & Mid(shipDate, 4, 2) & Mid(shipDate, 1, 2) & ";" & _ Trim(wsCopyFrom.Cells(3, intColumn).Text) & ";" & Trim(wsCopyFrom.Cells(2, intColumn).Text) & _ ";;;;;;;999;;" Dim r As Integer r = 1 intAddRow = intAddRow + 1 While Trim(wsCopyFrom.Cells(intRow, intColBeg - 1).Text) <> "" If (Trim(wsCopyFrom.Cells(intRow, intColumn).Text) <> "") Then If Round(CDbl(Trim(wsCopyFrom.Cells(intRow, intColumn).Value)), 0) > 0 Then ' Rows of an Order wsCopyTo.Cells(intAddRow, 1) = "I;" & orderId & "/" & orderNum & ";" & r & ";" & _ Trim(wsCopyFrom.Cells(intRow, 1).Text) & ";" & Trim(wsCopyFrom.Cells(intRow, intColumn).Value) & _ ";PCE;;;;;;;;;;;;;;;" r = r + 1 intAddRow = intAddRow + 1 End If End If intRow = intRow + 1 Wend intRow = intRowBeg intColumn = intColumn + 1 orderNum = orderNum + 1 Wend wbCopyFrom.Close wbCopyTo.Sheets("BASE").Activate End Sub Sub Export() Dim MyPath As String Dim MyFileName As String MyFileName = "Orders_" & Sheets("BASE").Cells(7, 3).Text & "_" & Format(Date, "ddmmyyyy") If Not Right(MyFileName, 4) = ".csv" Then MyFileName = MyFileName & ".csv" Sheets("DATA").Copy With Application.FileDialog(msoFileDialogFolderPicker) .Title = "Select a Folder" .AllowMultiSelect = False .InitialFileName = "" '<~~ The start folder path for the file picker. If .Show <> -1 Then GoTo NextCode MyPath = .SelectedItems(1) & "\" End With NextCode: If MyPath <> "" Then Application.DisplayAlerts = False With ActiveWorkbook .SaveAs fileName:=MyPath & MyFileName, AccessMode:=xlExclusive, FileFormat:=xlCSV, CreateBackup:=False, ConflictResolution:=Excel.XlSaveConflictResolution.xlLocalSessionChanges .Close False End With Application.DisplayAlerts = True Else On Error Resume Next ActiveWorkbook.Close SaveChanges:=False If Err.Number = 1004 Then On Error GoTo 0 End If End If End Sub
我相信这个代码并不是最优的，因为我没有任何VBA的经验，它是一种在debugging模式下尝试/更改/再次尝试并在出现问题时使用Googlesearch的方法。
如果你可以提供任何build议，如何优化 – 这将是伟大的！