用於數據集的Excel VBA宏

Question

我需要從數據集矩陣中創建一個csv文件，其中我有材料作爲行，人物作爲列和交叉點上的產品數量。下面是該數據集的示例（訂單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」要求的交貨日期，「L」的第一子訂單 - 線行，「1」 - 行號，「EA」 - 度量單位。

Answer 1

下面是一個宏，它可以幫你實現最大的目標。它將第一個表中的數據組織起來，以便將相似列（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 

Answer 2

Thanks @ChrisB for your answer。其實，我決定做我自己的路，這裏是我做的主要步驟：

1. 我創建一個Excel幾個按鈕文件，我分配到下面的子程序。另外我添加了一些參數，用戶可以修改（OrderId，Delivery Date和WH id）。
2. 我創建了一個子程序ReadData（），它清除原始文件中的Sheet「DATA」，並在數據文件中逐列讀取後生成一個包含「DATA」表中所有必填字段的線性數據集。
3. 之後，我只是寫「數據」表到外部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經驗，這是試圖/改變方法/努力再次在調試模式和搜索問題的情況下。

如果您可以提供任何建議如何優化它 - 那會很棒！