Невозможно выполнить копирование с заданного листа при прохождении через данные

У меня был более ранний вопрос, на который был любезно ответил, и мне был предоставлен следующий код, который отлично работал в тестовой среде, где код выполнялся через 3 листа с только 1 листом данных и тремя столбцами.

Ниже мой измененный код проходит через 16 столбцов. Проблема, однако, я считаю, что я сталкиваюсь, когда открываю лист в живой среде, в суб-книгах все содержат 4 вкладки, которые являются «Lookup», «Detail», «Summary» и «Calls».

Код содержит For Each sheet In ActiveWorkbook.Worksheets

Я хочу только взять данные в приведенном ниже коде из каждой книги в цикле на вкладке «Вызовы». Может ли кто-нибудь порекомендовать какое-либо изменение существующего цикла для этого?

 Sub Theloopofloops() Dim wbk As Workbook Dim Filename As String Dim path As String Dim rCell As Range Dim rRng As Range Dim wsO As Worksheet Dim sheet As Worksheet Set sheet = ActiveWorkbook.Sheets(Sheet2) path = "M:\Documents\Call Logger\" Filename = Dir(path & "*.xlsm") Set wsO = ThisWorkbook.Sheets("Master") Do While Len(Filename) > 0 DoEvents Set wbk = Workbooks.Open(path & Filename, True, True) For Each sheet In ActiveWorkbook.Worksheets Set rRng = sheet.Range("A2:A20000") For Each rCell In rRng.Cells If rCell <> "" And rCell.Value <> vbNullString And rCell.Value <> 0 Then wsO.Cells(wsO.Rows.Count, 1).End(xlUp).Offset(1, 0).Value = rCell wsO.Cells(wsO.Rows.Count, 1).End(xlUp).Offset(0, 1).Value = rCell.Offset(0, 1) wsO.Cells(wsO.Rows.Count, 1).End(xlUp).Offset(0, 2).Value = rCell.Offset(0, 2) wsO.Cells(wsO.Rows.Count, 1).End(xlUp).Offset(0, 3).Value = rCell.Offset(0, 3) wsO.Cells(wsO.Rows.Count, 1).End(xlUp).Offset(0, 4).Value = rCell.Offset(0, 4) wsO.Cells(wsO.Rows.Count, 1).End(xlUp).Offset(0, 5).Value = rCell.Offset(0, 5) wsO.Cells(wsO.Rows.Count, 1).End(xlUp).Offset(0, 6).Value = rCell.Offset(0, 6) wsO.Cells(wsO.Rows.Count, 1).End(xlUp).Offset(0, 7).Value = rCell.Offset(0, 7) wsO.Cells(wsO.Rows.Count, 1).End(xlUp).Offset(0, 8).Value = rCell.Offset(0, 8) wsO.Cells(wsO.Rows.Count, 1).End(xlUp).Offset(0, 9).Value = rCell.Offset(0, 9) wsO.Cells(wsO.Rows.Count, 1).End(xlUp).Offset(0, 10).Value = rCell.Offset(0, 10) wsO.Cells(wsO.Rows.Count, 1).End(xlUp).Offset(0, 11).Value = rCell.Offset(0, 11) wsO.Cells(wsO.Rows.Count, 1).End(xlUp).Offset(0, 12).Value = rCell.Offset(0, 12) wsO.Cells(wsO.Rows.Count, 1).End(xlUp).Offset(0, 13).Value = rCell.Offset(0, 13) wsO.Cells(wsO.Rows.Count, 1).End(xlUp).Offset(0, 14).Value = rCell.Offset(0, 14) wsO.Cells(wsO.Rows.Count, 1).End(xlUp).Offset(0, 15).Value = rCell.Offset(0, 15) End If Next rCell Next sheet wbk.Close False Filename = Dir Loop End Sub 

вы можете последовать за следующим:

 Option Explicit Sub Theloopofloops() Dim wbk As Workbook Dim Filename As String Dim path As String Dim rCell As Range Dim wsO As Worksheet path = "M:\Documents\Call Logger\" Filename = Dir(path & "*.xlsm") Set wsO = ThisWorkbook.Sheets("Master") Do While Len(Filename) > 0 DoEvents Set wbk = Workbooks.Open(path & Filename, True, True) For Each rCell In ActiveWorkbook.Worksheets("Calls").Range("A2:A20000") If rCell <> "" And rCell.Value <> vbNullString And rCell.Value <> 0 Then wsO.Cells(wsO.Rows.Count, 1).End(xlUp).Offset(1, 0).Resize(, 16).Value = rCell.Resize(, 16).Value End If Next rCell wbk.Close False Filename = Dir Loop End Sub 

Вместо использования цикла просто замените строку « For Each sheet ...

 Set sheet = wbk.Worksheets("Calls") 

(и удалить Next sheet )

Вы могли бы даже сократить это и использовать

 Set rRng = wbk.Worksheets("Calls").Range("A2:A20000") 

или даже пропустить это и использовать

 For Each rCell In wbk.Worksheets("Calls").Range("A2:A20000").Cells 

Вы также можете сократить копирование, используя

 wsO.Cells(wsO.Rows.Count, 1).End(xlUp).Offset(1, 0).Resize(1, 16).Value = rCell.Resize(1, 16).Value 
  • Цитирование через рабочие листы
  • Python, цикл высказываний, тянущихся от excel
  • Работа с вложенными циклами в Python - Параметры?
  • VBA Удалите точки и подсчитайте цифры до места
  • Как перебрать несколько листов excel и добавить имя листа в новый столбец?
  • Петлевые ячейки в VBA.
  • Как сделать расчет по нескольким строкам и подвести итоги
  • Как остановить Loop в Vba
  • Ссылка на строку внутри массива формул в Excel VBA
  • Вставка буфера обмена в новую рабочую книгу VBA Macro
  • VBA вырезает каждую другую строку в последнюю строку в столбце и вставляет в новый столбец, а затем удаляет пустые строки
  • Interesting Posts

    Как получить последний измененный файл в каталоге с помощью VBA в Excel 2010

    Count ifs, основанный на нескольких критериях и дате

    Excel VBA – Сравнение строк таблицы на основе ценности

    График Excel VBA, показать метку данных только в последней точке

    Различные команды SQL для разных листов Excel

    Как я могу вернуть пустой как null для всех ячеек в файле .xlsx с помощью Apache POI?

    Запуск Excel Macro через VBA в Acces

    Хранить объекты на листе Excel?

    Excel в веб-приложении C # пропускает некоторые заголовки и не форматирует

    Как получить имя строки, выбранной в ListBox в VBA

    Внутри цикла, как указывать «все строки» при использовании среднего числа столбцов (Visual Basic)

    Получение данных из закрытой книги на основе содержимого ячейки в открытом листе

    Как форматировать текст ячейки excel при открытии содержимого HTML

    Excel, используйте значение, возвращаемое функцией, чтобы выбрать соответствующую ячейку

    Как я могу получить excel для обновления электронной таблицы для RTD Excel-DNA?

    Давайте будем гением компьютера.