Сбор данных из нескольких книг Видимый диапазон

[kosteg]

Всем привет! На сайте есть супер макрос для сбора данных из нескольких листов/книг:
https://www.excel-vba.ru/chto-umeet-excel/kak-sobrat-dannye-s-neskolkix-listov-ili-knig/comment-page-30/#comment-254645
Я никак не могу доработать его таким образом, чтобы копировались данные только из НЕ скрытых строк. Например (во вложении Книга1 и Книга2) - на листе есть три таблицы, две из которых всегда скрыты. Когда я запускаю макрос сбора данных, указав диапазон = "Область печати", то он копирует всё независимо от того скрыты строки или нет. Пробовал использовать ".SpecialCells(xlCellTypeVisible)" - выдает ошибку "Это невозможно сделать в объединённой ячейке". Пробовал добавить проверку скрытости строк через If

Код Выделить Развернуть

With wsSh
If Range("A3").EntireRow.Hidden = True And Range("A26").EntireRow.Hidden = True Then Set iBeginRange = Range("A58:k73")
If Range("A26").EntireRow.Hidden = True And Range("A58").EntireRow.Hidden = True Then Set iBeginRange = Range("A3:k18")
If Range("A3").EntireRow.Hidden = True And Range("A58").EntireRow.Hidden = True Then Set iBeginRange = Range("A26:k47")работает, но только с первым файлом. На втором выдает ошибку "object requred" по строке "sCopyAddress = iBeginRange.Address"
Просьба помочь гуру форумчан доработать макрос для копирования только видимых строк.
Вы не можете просматривать это вложение.
Вы не можете просматривать это вложение.
Вы не можете просматривать это вложение. 

[kosteg]

Проблема решена, код прилагаю. Думаю, добавлю ещё в него статус-бар, т.к. при обработке 500-700 файлов он будет очень полезен для наглядности процесса.

Код Выделить Развернуть

Sub MergeTablesFromMultipleWorkbooks()
    Dim targetSheet As Worksheet
    Dim sourceFolder As String
    Dim sourceFile As String
    Dim sourceWorkbook As Workbook
    Dim sourceRange As Range
    Dim visibleData As Range
    Dim lastRow As Long
    Dim firstFile As Boolean
    Dim startRow As Long
    Dim fileName As String
   
    ' Настройки
    Set targetSheet = ThisWorkbook.Sheets("Объединенные данные")
    sourceFolder = GetFolderPath()
    If sourceFolder = "" Then Exit Sub
   
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    Application.EnableEvents = False
    firstFile = True
    sourceFile = Dir(sourceFolder & "\*.xls*")
   
    ' Инициализация целевого листа
    targetSheet.Cells.Delete
    targetSheet.Range("A1").Value = "Источник файла"
   
    Do While sourceFile <> ""
        If sourceFile <> ThisWorkbook.Name Then
            Set sourceWorkbook = Workbooks.Open(sourceFolder & "\" & sourceFile)
            fileName = Split(sourceFile, ".")(0)
           
            With sourceWorkbook.Sheets("Расчет суммы кредита") 'ТУТ ИМЯ ВАШЕГО ЛИСТА
                ' Снятие защиты листа с проверкой
                On Error Resume Next
                .Unprotect Password:="-П А Р О Л Ь-" ' Укажите ваш пароль если известен или закомментируйте блок
                On Error GoTo 0
               
                ' Проверка на пустой файл
                lastRow = .Cells(.Rows.Count, 1).End(xlUp).Row
                If lastRow < 1 Then
                    MsgBox "Файл " & sourceFile & " пуст", vbExclamation
                    GoTo CloseWorkbook
                End If
               
                Set sourceRange = .Range("A1:k" & lastRow) 'ТУТ УКАЖИТЕ ДИАПАЗОН КОПИРОВАНИЯ
            End With
           
            With targetSheet
                If firstFile Then
                    ' Копируем заголовки как значения
                    sourceRange.Rows(1).Copy
                    .Range("B1").PasteSpecial xlPasteValues
                    firstFile = False
                End If
               
                ' Получаем видимые данные с обработкой ошибок
                On Error Resume Next
                Set visibleData = sourceRange.Offset(1).Resize(sourceRange.Rows.Count - 1) _
                                  .SpecialCells(xlCellTypeVisible)
                On Error GoTo 0
               
                ' Проверяем наличие видимых данных
                If Not visibleData Is Nothing Then
                    startRow = .Cells(.Rows.Count, 2).End(xlUp).Row + 1
                   
                    ' Копируем только значения
                    On Error Resume Next
                    .Range("B" & startRow).Resize(visibleData.Rows.Count, visibleData.Columns.Count).Value = _
                        visibleData.Value
                    On Error GoTo 0
                   
                    ' Заполняем колонку с именем файла
                    lastRow = .Cells(.Rows.Count, 2).End(xlUp).Row
                    If lastRow >= startRow Then
                        .Range("A" & startRow & ":A" & lastRow).Value = fileName
                    End If
                Else
                    MsgBox "В файле " & sourceFile & " нет видимых данных", vbExclamation
                End If
            End With

CloseWorkbook:
            sourceWorkbook.Close False
            Set visibleData = Nothing
        End If
        sourceFile = Dir()
    Loop
   
    Application.CutCopyMode = False
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
    Application.EnableEvents = True
    ' Форматирование результата
    With targetSheet
        .Rows(1).Font.Bold = True
'        .Columns.AutoFit
        If .Cells(1, 2) = "" Then .Cells(1, 2) = "Нет данных"
    End With
   
    MsgBox "Объединено " & targetSheet.Cells(targetSheet.Rows.Count, 2).End(xlUp).Row - 1 & " строк", vbInformation
End Sub
Function GetFolderPath() As String
    With Application.FileDialog(msoFileDialogFolderPicker)
        .Title = "Выберите папку с исходными файлами"
        .AllowMultiSelect = False
        If .Show = -1 Then
            GetFolderPath = .SelectedItems(1)
        Else
            GetFolderPath = ""
        End If
    End With
End Function