如何使用宏将“缩进级别”转换为SUBTOTAL公式？

Question

我获得了100多个excel工作表，每个工作表都有成千上万个如下所示的条目：

*注意：文件中仅前三列。我想修改第三列，或添加第四列，如上所示。

我需要编辑这些文件，删除某些行，并且总的汇总价格必须正确。不幸的是，C列使用值进行了硬编码。 如何将“价格”列转换为使用最右边一列的小计功能？也就是说，根据前3列自动生成D列。我不想逐行浏览每个文件。

我有缩进级别，从理论上讲应该很容易，但是我以前从未真正使用过宏。我不确定仅凭公式如何实现，但我想可以做到。

我可以修改C列或创建其他列D。

Answer 1

我已经生成了您想要的公式（我认为），但是这些公式无法求出您想要的值。也许您可以看到我忽略的错误。函数SUBTOTAL可能受到我不知道的开关的影响。但是，首先介绍一下我所创建的内容。

我需要一些测试数据，因此创建了一个工作表，其中包含示例中的重要列：

B列与列标题无关。我已经仔细检查过，据我所知，A和C列与您的示例相符。

您说您有100多张纸，但是没有说它们是全部放在一本工作簿中还是散布在几本工作簿中。我假设了几本工作簿。每个工作表中可能只有一个程序集，但是以防万一，我已经复制了您的程序集副本，因此每个工作表中有多个程序集。我复制了工作表，所以每个工作簿有两个。然后，我创建了工作簿的两个副本。结果是我有三个数据工作簿，每个工作簿都有两个要处理的工作表。我以其他格式创建了其他工作表，因此可以检查是否忽略了不处理的工作表。

我不想将宏复制到每个数据工作簿，因此我有另一个工作簿，该工作簿启用了宏来保存我的宏。我将所有四个工作簿放在一个文件夹中。我认为这对您来说不是问题。如果无法将所有工作簿移动到单个文件夹，则必须描述您的文件夹结构，以便我决定如何处理它。

要匹配我的系统，您将需要创建一个启用宏的工作簿。该工作簿必须有一个名为“ Wshts”的工作表。

我通常将宏分散到几个模块中。我描述了我的模块，但是您可以根据需要将所有代码放在一个模块中。

“ ModGlobal”模块包含列和行常量，以及我在为您编写的宏中使用的库中的两个例程：

Option Explicit

' Columns and first data row of worksheet "Wshts" of this workbook
Public Const ColWshtWbk As Long = 1
Public Const ColWshtWSht As Long = 2
Public Const RowWshtDataFirst As Long = 2

' Columns and first data row of a assembly worksheet
Public Const ColPartIndent As Long = 1
Public Const ColPartAmt As Long = 3
Public Const ColPartFormula As Long = 4
Public Const RowPartDataFirst As Long = 2
Public Function ColNumToCode(ByVal ColNum As Long) As String

  ' Convert an Excel column number to the equivalent code. For example 1 to "A".

  Dim ColCode As String
  Dim PartNum As Long

  ' 3Feb12  Adapted to handle three character codes.
  ' ??????  Renamed from ColCode to create a more helpful name

  If ColNum = 0 Then
    ColNumToCode = "0"
  Else
    ColCode = ""
    Do While ColNum > 0
      PartNum = (ColNum - 1) Mod 26
      ColCode = Chr(65 + PartNum) & ColCode
      ColNum = (ColNum - PartNum - 1) \ 26
    Loop
  End If

  ColNumToCode = ColCode

End Function
Public Function PadL(ByVal Str As String, ByVal PadLen As Long, _
                     Optional ByVal PadChr As String = " ") As String

  ' Pad Str with leading PadChr to give a total length of PadLen
  ' If the length of Str exceeds PadLen, Str will not be truncated

  '   Sep15 Coded
  ' 20Dec15 Added code so overlength strings are not truncated
  ' 10Jun16 Added PadChr so could pad with characters other than space

  If Len(Str) >= PadLen Then
    ' Do not truncate over length strings
    PadL = Str
  Else
    PadL = Right$(String(PadLen, PadChr) & Str, PadLen)
  End If

End Function

工作表“ Wshts”必须包含要处理的工作表的列表。模块“ ModListWshts”包含以下代码：

Option Explicit
Sub ListWshts()

  ' Build list of workbooks and worksheets to be processed by macro GenFormulae

  Dim FileName As String
  Dim InxWsht As Long
  Dim PathName As String
  Dim RowWsht As Long
  Dim WBk As Workbook
  Dim WshtWsht As Worksheet

  Application.ScreenUpdating = False

  Set WshtWsht = ThisWorkbook.Worksheets("Wshts")
  With WshtWsht
    .Cells.EntireRow.Delete
    .Cells(1, ColWshtWbk).Value = "Workbook"
    .Cells(1, ColWshtWSht).Value = "Worksheet"
    .Rows(1).Font.Bold = True
  End With
  RowWsht = 2

  PathName = ThisWorkbook.Path & "\"

  FileName = Dir$(PathName & "*.xls*", vbNormal)
  Do While FileName <> ""
    If FileName <> ThisWorkbook.Name Then
      'Debug.Print FileName
      Set WBk = Workbooks.Open(PathName & FileName, False, True)
      With WBk
        For InxWsht = 1 To .Worksheets.Count
          'Debug.Print "  " & .Worksheets(InxWsht).Name
          WshtWsht.Cells(RowWsht, ColWshtWbk).Value = FileName
          WshtWsht.Cells(RowWsht, ColWshtWSht).Value = .Worksheets(InxWsht).Name
          RowWsht = RowWsht + 1
        Next
        .Close
      End With
    End If
    FileName = Dir$
  Loop

  WshtWsht.Columns.AutoFit

  Application.ScreenUpdating = False

End Sub

此宏在文件夹中找到所有工作簿，并创建工作簿及其工作表的列表。我删除了我不想处理的工作表的行：

如果运行宏ListWshts，则此工作簿上的版本将超过100行。我认为六个就够了。删除工作表中将不处理的所有行。创建这样的列表的方法比较复杂，但是我对您的工作簿的了解还不够多，因此无法找到更合适的方法。

最后，模块“ GenGenFormulae”包含：

Option Explicit
Sub GenFormulae()

  ' Workbooks and worksheets to be processed are listed in worksheet Wshts.
  ' Generate a formula for each row of each worksheet to be processed.

  Dim FileNameCrnt As String
  Dim FileNameLast As String
  Dim InxWsht As Long
  Dim LevelCrnt As Long
  Dim LevelLast As Long
  Dim OpenLevelStart(0 To 999)      ' Allow for more levels than could possibly exist
                                    ' to avoid worrying about array overflow
  Dim PathName As String
  Dim RowPartCrnt As Long
  Dim RowPartLast As Long
  Dim RowWshtCrnt As Long
  Dim RowWshtLast As Long
  Dim WBk As Workbook
  Dim WshtPart As Worksheet
  Dim WshtWsht As Worksheet

  Application.ScreenUpdating = False

  Set WshtWsht = ThisWorkbook.Worksheets("Wshts")
  RowWshtLast = WshtWsht.Cells(Rows.Count, ColWshtWbk).End(xlUp).Row

  PathName = ThisWorkbook.Path & "\"
  FileNameLast = ""

  For RowWshtCrnt = RowWshtDataFirst To RowWshtLast
    Application.StatusBar = "Worksheet " & RowWshtCrnt - 1 & " of " & RowWshtLast - 1
    FileNameCrnt = WshtWsht.Cells(RowWshtCrnt, ColWshtWbk).Value

    If FileNameCrnt <> FileNameLast Then
      ' New workbook
      If FileNameLast <> "" Then
        ' Have an open workbook
        WBk.Close SaveChanges:=True
        Set WBk = Nothing
      End If
      FileNameLast = FileNameCrnt
      Debug.Print "Workbook " & FileNameCrnt
      Set WBk = Workbooks.Open(PathName & FileNameCrnt)
    End If

    ' Reference worksheet within open workbook
    With WBk
      Set WshtPart = .Worksheets(WshtWsht.Cells(RowWshtCrnt, ColWshtWSht).Value)
    End With

    ' Process worksheet
    With WshtPart
      RowPartLast = .Cells(Rows.Count, ColPartIndent).End(xlUp).Row
      Debug.Print "  Worksheet " & .Name & " (" & RowWshtCrnt - 1 & _
                  " of " & RowWshtLast - 1 & " in total) which has " & _
                  RowPartLast - 1 & " rows."

      ' Process Row RowPartDataFirst which has no previous row.
      RowPartCrnt = RowPartDataFirst
      LevelLast = CLng(Replace(.Cells(RowPartCrnt, ColPartIndent).Value, ".", ""))
      Debug.Assert LevelLast = 0   ' First data row must be level 0

      ' Unless overridden by the next row, the formula for the
      ' current row is a copy of the amount from the current row
      .Cells(RowPartCrnt, ColPartFormula).Value = _
                                        "=" & ColNumToCode(ColPartAmt) & RowPartCrnt
      'Debug.Print "    Row " & CStr(RowPartCrnt) & ", Level " & LevelCrnt

      For RowPartCrnt = RowPartDataFirst + 1 To RowPartLast

        ' For each row create the default formula, decide if the previous
        ' row requires a non-default formula and if any earlier sub-total
        ' formulae were terminated by this row

        If RowPartCrnt Mod 100 = 0 Then
          ' Display progress every 100 rows
          Application.StatusBar = "Worksheet " & RowWshtCrnt - 1 & " of " & RowWshtLast - 1 & _
                                  ".  Row " & RowPartCrnt - 1 & " of " & RowPartLast - 1
        End If

        LevelCrnt = CLng(Replace(.Cells(RowPartCrnt, ColPartIndent).Value, ".", ""))

        ' Unless overridden by the next row, the formula for the
        ' current row is a copy of the amount from the current row
        .Cells(RowPartCrnt, ColPartFormula).Value = _
                                        "=" & ColNumToCode(ColPartAmt) & RowPartCrnt
        'Debug.Print "    Row " & RowPartCrnt & ", Level " & LevelCrnt;
        If LevelCrnt = LevelLast Then
          ' This row at same level as last.
          ' No earlier row affected by this row
          'Debug.Assert False
          'Debug.Print    ' Finish diagnostic line containing row and level
        ElseIf LevelCrnt = LevelLast + 1 Then
          ' This row is immediate child of last row.
          ' Formula for previous row is at level LevelLast
          ' with the range starting on current row
          ' Store range start until range end found
          'Debug.Assert False
          OpenLevelStart(LevelLast) = RowPartCrnt
          'Debug.Print "   Start of level " & LevelLast & " subtotal"
        ElseIf LevelLast > LevelCrnt Then
          ' This row is at a lower level than last row.
          ' Levels LevelLast-1 to LevelCrnt ended on last row.
          'Debug.Assert False
          'Debug.Print
          Do While LevelLast > LevelCrnt
            LevelLast = LevelLast - 1
            'Debug.Print Space(6) & "Level " & LevelLast & " subtotal on row " & _
                        OpenLevelStart(LevelLast) - 1 & " with range " & _
                        OpenLevelStart(LevelLast) & " to " & RowPartCrnt - 1
            .Cells(OpenLevelStart(LevelLast) - 1, ColPartFormula).Value = _
                             "=SUBTOTAL(9," & ColNumToCode(ColPartAmt) & _
                             OpenLevelStart(LevelLast) & ":" & _
                             ColNumToCode(ColPartAmt) & RowPartCrnt - 1 & ")"
          Loop
        Else
          ' No code for this combination of current and last level
          Debug.Assert False
        End If
        LevelLast = LevelCrnt
      Next RowPartCrnt
    End With
    Set WshtPart = Nothing  ' This worksheet finished
  Next RowWshtCrnt

  WBk.Close SaveChanges:=True
  Set WBk = Nothing

  Application.ScreenUpdating = False

End Sub

运行宏GenFormulae。它会根据需要打开工作簿，并处理工作表“ Wshts”中列出的每个工作表。它将公式写入D列。它不会将A列更改为C列，因此您可以根据需要重新运行宏。宏会进行一些有限的数据检查，但是通常来说，如果它不喜欢发现的内容，它只会停止。宏使用状态栏和立即窗口来指示进度。使用我的六个小型工作表，只需要几秒钟。我推断您将修复这些工作表，然后不再需要此宏。如果这是一项重复性任务，则可能需要更好的进度指示器。

这是我运行GenFormulae后处于公式模式的工作表之一：

这似乎包含所需的公式。但是，在数据模式下，工作表为：

如您所见，值不是您想要的。正如我在顶部说的那样，也许您可​​以明白为什么。