Цитата |
---|
bikeza написал: ошибка при запуске макроса (см.скрин). Других - это каких? Не смет? Кроме смет файлов не было |
Извиняюсь, лишнее нажатие клавиши по время вставки комментария. Поправил.
Скрытый текст |
---|
Код |
---|
Sub КучаСмет()
'aequit 15.02.2020 v.2
Dim Wb As Workbook, ws As Worksheet
Dim wbTmp As Workbook
Dim sFname As String
Dim lR As Long, sFolder As String
Dim lN As Long, i As Long, lLastRow As Long
Dim iCell, lS As Long
Application.ScreenUpdating = False
Set Wb = ThisWorkbook
Set ws = Wb.Worksheets(1)
ws.Cells.Clear
ws.[A2] = "№" & Chr(10) & "п/п"
ws.[B2] = "Наименование"
ws.[C2] = "Кол-во" & Chr(10) & "позиций"
sFolder = Wb.Path & "\"
sFname = Dir(sFolder & "*.xlsx")
Do While sFname <> ""
lN = 0
Set wbTmp = GetObject(sFolder & sFname)
Windows(wbTmp.Name).Visible = True
lR = ActiveSheet.Cells.Find("Наименование работ и затрат", _
searchorder:=xlByRows, searchdirection:=xlPrevious).Row + 4
lLastRow = ActiveSheet.Cells(Rows.Count, 1).End(xlUp).Row
For i = lR To lLastRow
If ActiveSheet.Cells(i, 9).MergeArea.Rows.Count = 2 Then
lN = lN + 1
End If
Next i
lN = 0.5 * lN
lLastRow = ws.Cells(Rows.Count, 1).End(xlUp).Row
ws.Cells(lLastRow + 1, 1) = lLastRow - 1
ws.Cells(lLastRow + 1, 2) = Left(wbTmp.Name, Len(wbTmp.Name) - 5)
ws.Cells(lLastRow + 1, 3) = lN
wbTmp.Close False
Set wbTmp = Nothing
lS = lS + lN
sFname = Dir
Loop
ws.Cells(lLastRow + 2, 2) = "ИТОГО"
ws.Cells(lLastRow + 2, 3) = lS
With ws.[B2].CurrentRegion
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
.Borders.LineStyle = True
End With
ws.Columns("A:C").AutoFit
ws.Columns("B:B").HorizontalAlignment = xlLeft
Wb.Save
Application.ScreenUpdating = False
End Sub |
|
P.s. Проверил все сметы из нового архива. Мой алгоритм отработал и посчитал всё корректно. В коде добавил выравнивание в ячейках и подбор ширины (несущественно, на результат не влияет). При том треше, что творится в Ваших файлах (после пункта 1 в нумерации идет пункт 12 или вообще буквы "О" и др.), вполне возможно, что есть в других сметах нечто иное, что может вызвать ошибку в подсчетах. Если при тестировании такой файл проявится, можете приложить его в этой теме или создать новую, подумаем, что можно сделать...
В присланном Вами архиве есть файл "Свод PQ.xlsx", его в папке со сметами быть не должно. Если этой папке будет другой файл, отличный от сметы, при его открытии появится ошибка, так как обработка ошибок в процедуре не сделана (можно добавить при необходимости). Также нетрудно добавить возможность выбора папки со сметами. В текущем варианте файл "Свод.xlsm" нужно просто положить в папку со сметами и нажать на единственную кнопку. Должен появиться такой результат (на скриншоте).
При тестировании обратите внимание на результаты обработки смет: "11527-Д", "55362 Изм.1" и "55454 изм .2 ОТОПЛЕНИЕ", на наличие итоговой суммы и её корректность, а также на полноту имен файлов (смет) в таблице.