Всем привет! По сути у меня имеется готовый макрос, который работает, но он немного неправильно заточен, приходится вручную вносить изменения.
Обрезка лишних строк сверху происходит по признаку в файле "№ п.п.", но у сметчиц разное видение своего файла, кто то пишет- №п.п, кто то- № п/п, поэтому выскакивает ошибка или приходится в ручную вносить изменения, бывает сметный файл с колонки "А", а бывает с колонки "В", после этого опять некорректное заполнение файла в моем ексель. Это в кратце о моих проблемах.
Суть задачи, сделать макросом или иным действующим способом корректное заполнение файла ексель, что бы заполнялись колонки:
2 строка:
| № п.п. | Обоснование | Наименование работ и затрат | Единица измерения | Количество |
3 строка и далее содержимое этих колонок.
Бюджет 500 рублей
Если кому то нужно, то вот макрос которым собираю информацию с файла сметчицы:
Скрытый текст |
|---|
Sub Smeta_sbor()
' Очистить строки перед загрузкой сметы
Rows("2:2000").Select
Range("B2").Activate
Selection.Delete Shift:=xlUp
' Заходим на лист СМЕТА, удаляем данные со 2 строки.
Dim iBeginRange As Object, lCalc As Long, lCol As Long
Dim oAwb As String, sCopyAddress As String, sSheetName As String
Dim lLastRow As Long, lLastRowMyBook As Long, li As Long, iLastColumn As Integer
Dim wsSh As Object, wsDataSheet As Object, bPolyBooks As Boolean, avFiles
Dim wbAct As Workbook
Dim bPasteValues As Boolean
Dim CurW As Window
Dim TempW As Window
Application.DisplayAlerts = False 'это должно отключать лишние запросы екселя и ошибки - в конце включить назад
Application.Calculation = xlAutomatic 'включаю автом.расчет формул( чет выключается по чему то в конце макроса)
On Error Resume Next
'Выбираем диапазон выборки с книг
'Set iBeginRange = Application.InputBox("Выберите диапазон сбора данных." & vbCrLf & _
"1. При выборе только одной ячейки данные будут собраны со всех листов начиная с этой ячейки. " & _
vbCrLf & "2. При выделении нескольких ячеек данные будут собраны только с указанного диапазона всех листов.", Type:=8)
'для указания диапазона без диалогового окна:
Set iBeginRange = Range("A2") 'диапазон указывается нужный
'Если диапазон не выбран - завершаем процедуру
If iBeginRange Is Nothing Then Exit Sub
'Указываем имя листа
'Допустимо указывать в имени листа символы подставки ? и *.
'Если указать только * то данные будут собираться со всех листов
' sSheetName = InputBox("Введите имя листа, с которого собирать данные(если не указан, то данные собираются со всех листов)", "Параметр")
sSheetName = "" ' указываем имя листа
'Если имя листа не указано - данные будут собраны со всех листов
If sSheetName = "" Then sSheetName = "*"
On Error GoTo 0
'Запрос - вставлять на результирующий лист все данные
'или только значения ячеек (без формул и форматов)
'bPasteValues = (MsgBox("Вставлять только значения?", vbQuestion + vbYesNo, "Excel-VBA") = vbYes)
bPasteValues = (vbYes)
'Запрос сбора данных с книг(если Нет - то сбор идет с активной книги)
If MsgBox("Собрать данные?", vbInformation + vbYesNo, "Excel-VBA") = vbYes Then
' avFiles = Application.GetOpenFilename("Excel files(*.xls*),*.xls*", , "Выбор файлов", , True)
avFiles = Application.GetOpenFilename("Excel files(*.xls*),*.xls*", , "Выбор файлов", , True)
'Workbooks.Open CSVfilename, local:=True 'куда засунуть это, что бы открывались нормальные обычные таблицы.
If VarType(avFiles) = vbBoolean Then Exit Sub
bPolyBooks = True
lCol = 1
Else
avFiles = Array(ThisWorkbook.FullName)
End If
'отключаем обновление экрана, автопересчет формул и отслеживание событий
'для скорости выполнения кода и для избежания ошибок, если в книгах есть иные коды
With Application
lCalc = .Calculation
.ScreenUpdating = False: .EnableEvents = False: .Calculation = xlManual
End With
'создаем новый лист в книге для сбора
' Set wsDataSheet = ActiveWorkbook.Sheets.Add(After:=Sheets(Sheets.Count))
Set wsDataSheet = Sheets("СМЕТА")
'если нужно сделать сбор данных на новый лист книги с кодом
'Set wsDataSheet = ThisWorkbook.Sheets.Add(After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count))
'цикл по книгам
For li = LBound(avFiles) To UBound(avFiles)
If bPolyBooks Then
Set wbAct = Workbooks.Open(Filename:=avFiles(li))
Else
Set wbAct = ThisWorkbook
End If
oAwb = wbAct.Name
'цикл по листам
For Each wsSh In wbAct.Sheets
If wsSh.Name Like sSheetName Then
'Если имя листа совпадает с именем листа, в который собираем данные
'и сбор идет только с активной книги - то переходим к следующему листу
If wsSh.Name = wsDataSheet.Name And bPolyBooks = False Then GoTo NEXT_
With wsSh
Select Case iBeginRange.Count
Case 1 'собираем данные начиная с указанной ячейки и до конца данных
lLastRow = .Cells(11, 1).SpecialCells(xlLastCell).Row
iLastColumn = .Cells.SpecialCells(xlLastCell).Column
'sCopyAddress = .Range(.Cells(iBeginRange.Row, iBeginRange.Column), .Cells(lLastrow, iLastColumn)).Address ' рабочая строка
sCopyAddress = .Range(.Cells(iBeginRange.Row, iBeginRange.Column), .Cells(lLastRow, 9)).Address 'нужны данные только до 9 столбца из источника
Case Else 'собираем данные с фиксированного диапазона
sCopyAddress = iBeginRange.Address
End Select
' lLastRowMyBook = wsDataSheet.Cells.SpecialCells(xlLastCell).Row + 1
lLastRowMyBook = wsDataSheet.Cells(1, 1).Row + 1
'If lCol Then wsDataSheet.Cells(lLastRowMyBook, 1).Resize(Range(sCopyAddress).Rows.Count).Value = oAwb вставляем имя книги, с которой собраны данные
If bPasteValues Then 'если вставляем только значения
.Range(sCopyAddress).Copy
wsDataSheet.Cells(3, 1).Offset(, lCol).PasteSpecial xlPasteValues ' wsDataSheet.Cells(lLastRowMyBook, 1).Offset(, lCol).PasteSpecial xlPasteValues
Else
.Range(sCopyAddress).Copy wsDataSheet.Cells(3, 1).Offset(, lCol) ' .Range(sCopyAddress).Copy wsDataSheet.Cells(lLastRowMyBook, 1).Offset(, lCol)
End If
End With
End If
NEXT_:
Next wsSh
If bPolyBooks Then wbAct.Close False
Next li
With Application
.ScreenUpdating = True: .EnableEvents = True: .Calculation = lCalc
End With
Range("A1").Select
lLastRow = Cells(Rows.Count,  .End(xlUp).Row
MsgBox (lLastRow) 'показывает сколько новых строк добавится в отчет.
Application.DisplayAlerts = True 'это должно отключать лишние запросы екселя и ошибки - в конце включить назад
Call HandTools
Dim r As Long, rng As Range
For r = 1 To ActiveSheet.UsedRange.Row - 1 + ActiveSheet.UsedRange.Rows.Count 'На листе СМЕТА удаляем пустые строки в загруженной смете
If Application.CountIf(Rows®, "?*") = 0 Then
If rng Is Nothing Then Set rng = Rows® Else Set rng = Union(rng, Rows®)
End If
Next r
Range("B:B").SpecialCells(xlCellTypeBlanks).EntireRow.Delete
End Sub
Sub HandTools() 'Удаляет строки сверху до строки №п.п
Dim iShp As Range
Dim iHT As Range
With Worksheets("СМЕТА")
Set iShp = .Columns(2).Find("№ п.п.1").Offset(1)
If iShp Is Nothing Then Exit Sub
Set iHT = .Columns(2).Find("№ п.п.").Offset(-1)
If iShp Is Nothing Then Exit Sub
.Rows(iShp.Row & ":" & iHT.Row).Delete
End With
End Sub |
