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 つの空の行を削除します。
  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 に答える