1

我有各种格式相同但编号不同的文件夹。前任：

OperatingUnit  "NO NAME"       GEP  NEP


      1         Disability     50   20
      2         MSL            20   2
      3         Aviation       5    6
      1         Disability     10   10
      3         Aviation       6    20

这些文件在列标题和实际数据之间有 2 个空行（如上所示）。我相信我有一个工作代码来循环遍历所有文件，所以现在我正在处理循环必须调用的宏。

我想要的是将数据放入一个新文件（我已经命名并放置列标题）中，并在它们下面包含以下值：

RptLOB      ECMAccount  Amount
Disability  GEP         60      (SUM of the GEP values where the "NO NAME" column = Disability)
Disability  NEP         30      (same as top but NEP values)
MSL         GEP         20
MSL         NEP         2
Aviation    GEP         11
Aviation    NEP         26

我不太确定我是否需要创建一个数据透视表，但因为在标题和数据之间有这 2 个空单元格，即使我手动尝试它也不会让我这样做。通过 VBA 解决这个问题的好方法是什么？

任何帮助将不胜感激！

4

1 回答 1

2

我知道我在这里过火了，但这是一个非常有趣的挑战:)

基本上，您选择需要导出的工作表，然后运行 ​​ExportData()。

它的工作方式是：

  1. 删除源数据中的前两个空行
  2. 按“NO NAME”对数据进行排序 - 这样更容易总结 GEP/NEP
  3. 浏览列表并创建一个用户定义类型的数组（其中包含我们在每个“NO NAME”基础上需要的所有信息）并根据需要总结值
  4. 创建一个新工作簿并通过遍历数组将数据导出到那里

这是代码：

Option Explicit

Public Enum SourceColumns
    OperatingUnit = 1
    NoName
    GEP
    NEP
End Enum

Public Enum DestinationColumns
    rptLob = 1
    ECMAccount
    Amount
End Enum

Public Type rptLob
    Name As String
    GEP As Long
    NEP As Long
End Type

Public Sub ExportData()
    Application.ScreenUpdating = False
    Dim sh As Excel.Worksheet
    Dim rptLobs() As rptLob

    Set sh = ActiveSheet

    Call removeTwoRows(sh)
    Call sortNoNameColumn(sh)

    rptLobs = getRptLOBs(sh)

    Call exportToNewWorkbook(rptLobs)
    Application.ScreenUpdating = True
End Sub

Private Sub removeTwoRows(ByRef sh As Excel.Worksheet)
    sh.Rows("2:3").EntireRow.Delete
End Sub

Private Sub sortNoNameColumn(ByRef sh As Excel.Worksheet)
    sh.Range("A1").AutoFilter
    With sh.AutoFilter
        .Sort.SortFields.Clear
        .Sort.SortFields.Add Key:=sh.Cells(1, SourceColumns.NoName) _
            , SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
        With .Sort
            .Header = xlYes
            .MatchCase = False
            .Orientation = xlTopToBottom
            .SortMethod = xlPinYin
            .Apply
        End With
    End With
End Sub

Private Function getRptLOBs(ByRef sh As Excel.Worksheet) As rptLob()
    Dim rptLobs() As rptLob
    Dim i As Long
    Dim lastRow As Long
    Dim curRptLOB As Long

    lastRow = sh.Cells(sh.Rows.Count, 1).End(xlUp).Row
    i = 2

    Dim firstRptLOB As rptLob

    ' set first values
    firstRptLOB.Name = sh.Cells(i, SourceColumns.NoName).Value
    firstRptLOB.GEP = sh.Cells(i, SourceColumns.GEP).Value
    firstRptLOB.NEP = sh.Cells(i, SourceColumns.NEP).Value

    ReDim rptLobs(0)
    rptLobs(curRptLOB) = firstRptLOB

    For i = 3 To lastRow
        If (sh.Cells(i, SourceColumns.NoName).Value <> rptLobs(curRptLOB).Name) Then
            ' get a new rptLOB
            Dim newRptLOB As rptLob

            ' set first values
            newRptLOB.Name = sh.Cells(i, SourceColumns.NoName).Value
            newRptLOB.GEP = sh.Cells(i, SourceColumns.GEP).Value
            newRptLOB.NEP = sh.Cells(i, SourceColumns.NEP).Value

            curRptLOB = curRptLOB + 1
            ReDim Preserve rptLobs(curRptLOB)

            rptLobs(curRptLOB) = newRptLOB
        Else
            ' add data to it
            rptLobs(curRptLOB).GEP = rptLobs(curRptLOB).GEP + sh.Cells(i, SourceColumns.GEP).Value
            rptLobs(curRptLOB).NEP = rptLobs(curRptLOB).NEP + sh.Cells(i, SourceColumns.NEP).Value
        End If
    Next

    getRptLOBs = rptLobs
End Function

Private Sub exportToNewWorkbook(ByRef rptLobs() As rptLob)
    Dim wb As Excel.Workbook
    Dim sh As Excel.Worksheet
    Dim index As Long
    Dim curRow As Long

    Set wb = Application.Workbooks.Add
    Set sh = wb.Sheets(1)

    ' Create Headers
    sh.Cells(1, DestinationColumns.rptLob).Value = "RptLOB"
    sh.Cells(1, DestinationColumns.ECMAccount).Value = "ECMAccount"
    sh.Cells(1, DestinationColumns.Amount).Value = "Amount"

    ' fill data
    For curRow = 2 To (UBound(rptLobs) + 1) * 2 + 1 Step 2 ' <-- double the amount of RptLOBs for GEP/NEP
        sh.Cells(curRow, DestinationColumns.rptLob).Value = rptLobs(index).Name
        sh.Cells(curRow, DestinationColumns.ECMAccount).Value = "GEP"
        sh.Cells(curRow, DestinationColumns.Amount).Value = rptLobs(index).GEP

        sh.Cells(curRow + 1, DestinationColumns.rptLob).Value = rptLobs(index).Name
        sh.Cells(curRow + 1, DestinationColumns.ECMAccount).Value = "NEP"
        sh.Cells(curRow + 1, DestinationColumns.Amount).Value = rptLobs(index).NEP

        index = index + 1
    Next
End Sub
于 2012-09-12T03:24:58.997 回答