Я создал формулы, которые вы хотите (я думаю), но эти формулы не оцениваются по значениям, которые вы хотите.Возможно, вы видите ошибку, которую я пропускаю.Возможно, на функцию SUBTOTAL влияет переключатель, о котором я не знаю.Но сначала введение в то, что я создал.
Мне понадобились некоторые тестовые данные, поэтому я создал таблицу, содержащую важные столбцы из вашего примера:
Столбец B и заголовки столбцов не имеют значения.Я тщательно проверил и, насколько я вижу, столбцы А и С. соответствуют вашему примеру.
Вы говорите, что у вас более 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:
По-видимому, содержит формулы, которые вы хотите.Однако в режиме данных рабочий лист выглядит следующим образом:
Как видите, значения не такие, как вы хотите.Как я сказал сверху, возможно, вы поймете, почему.