数据集的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

感谢@ChrisB的回答。实际上，我决定用我自己的方式来做这件事，下面是我做的主要步骤：

1. 我创建了一个带有几个按钮的Excel文件，我在下面的子例程中将这些按钮分配给了这些按钮。我还添加了一些参数，用户可以修改(OrderId，交付日期和WH id)。
2. 我创建了一个子例程ReadData()，它清除原始文件中的工作表" data“，并在读取数据文件中的列后，生成一个线性数据集，其中包含" data”工作表上的所有必需字段。
3. 之后，我只需将"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方面没有任何经验，它是一种在调试模式下尝试/更改/再次尝试的方法，并在出现问题的情况下进行谷歌搜索。

如果你能提供任何关于如何优化它的建议--那就太好了！