Попытался доработать макрос, под свои цели. Есть несколько файлов, для примера только два. В каждом содержится таблица с показателями сотрудника. В ячейке Н2 ФИО сотрудника. Необходимо собрать табличку с показателями, кроме нулевых, в первом столбце ФИО сотрудника.
При работе возник ряд вопросов, помогите с ответами пожалуйста:
1) If lCol Then wsDataSheet.Cells(lLastRowMyBook, 1).Resize(Range(sCopyAddress).Rows.Count).Value = Range("H2") Данная строка выдает ФИО, только для первого значения в Union Range("D10:D16") для остальных остается пустой, почему? как исправить?
2) Файлы содержат эл. подпись, поэтому при открытии выдает ошибку "файл поврежден". Из-за этого не работает Set wbAct = Workbooks.Open(Filename:=avFiles(li))
Приходится убирать эл. подпись, но хотелось бы ее сохранить, возможно заставить макрос игнорировать проблему? просто продолжить работать с файлом?
3)Для безопасности, что бы макрос работал именно в табличке куда записали данные хотел добавить With Workbooks("тест реестр.xlsm").Sheets("ПП")
Но выдает ошибку, пришлось использовать Select. В каких случаях можно использовать With с листом?
Спасибо.
| Код |
|---|
Sub Consolidated_Range_of_Books_and_Sheets()
Dim iBeginRange As Object, lCol As Long
Dim oAwb As String, sCopyAddress As String, sSheetName As String, sSubStr As String, sSubStr2 As String
Dim lLastrow As Long, lLastRowMyBook As Long, li As Long, iLastColumn As Integer
Dim wsSh As Object, wsDataSheet As Object, avFiles
Dim wbAct As Workbook
Dim bPasteValues As Boolean
Dim arr
Set iBeginRange = Union(Range("D10:D16"), Range("D18:D25"), Range("D27:D28"), Range("F10:H16"), Range("F18:H25"), Range("F27:H28"))
sSheetName = "Лист1"
On Error Resume Next
avFiles = Application.GetOpenFilename("Excel files(*.xls*), *.xls*", , "Выбрать книги", , True)
If VarType(avFiles) = vbBoolean Then Exit Sub
lCol = 1
With Application
.ScreenUpdating = False: .EnableEvents = False: .Calculation = xlManual
End With
Set wsDataSheet = Worksheets("ПП")
For li = LBound(avFiles) To UBound(avFiles)
Set wbAct = Workbooks.Open(Filename:=avFiles(li))
oAwb = wbAct.Name
For Each wsSh In wbAct.Sheets
If wsSh.Name Like sSheetName Then
With wsSh
sCopyAddress = iBeginRange.Address
lLastRowMyBook = wsDataSheet.Cells(Rows.Count, 1).End(xlUp).Row + 1
If lCol Then wsDataSheet.Cells(lLastRowMyBook, 1).Resize(Range(sCopyAddress).Rows.Count).Value = Range("H2")
.Range(sCopyAddress).Copy
wsDataSheet.Cells(lLastRowMyBook, 1).Offset(, lCol).PasteSpecial xlPasteValuesAndNumberFormats
End With
End If
Next wsSh
wbAct.Close False
Next li
'---------------------------------------------------------------------------
Workbooks("тест реестр.xlsm").Sheets("ПП").Select
sSubStr = "0"
lCol = 2
lLastrow = ActiveSheet.UsedRange.Row - 1 + ActiveSheet.UsedRange.Rows.Count
arr = Cells(1, lCol).Resize(lLastrow).Value
Dim rr As Range
For li = 1 To lLastrow
If CStr(arr(li, 1)) = sSubStr Then
If rr Is Nothing Then
Set rr = Cells(li, 1)
Else
Set rr = Union(rr, Cells(li, 1))
End If
End If
Next li
If Not rr Is Nothing Then rr.EntireRow.Delete
'---------------------------------------------------------------------------
With Application
.ScreenUpdating = True: .EnableEvents = True: .Calculation = xlAutomatic
End With
End Sub
|
