Excel VBA, чтобы вытащить Non-Null строк из других книг с именем range

Question

Новое на сайте со слабыми навыками VBA. Надеюсь, я смогу найти какую-то помощь, с которой я боролся в течение нескольких дней. Я нашел много примеров, которые близки, и, похоже, не могут жениться на них вместе. Я использую Excel 2007. У меня есть «Сводная_реестра» WB, а также несколько других книг, названных сотрудником (например, «Jim.xls», «bob.xls» и т. Д.). Каждая из рабочих книг имеет именованные диапазоны «шапки», полученные из листа «Задачи». Этот именованный диапазон в каждом сотруднике wb имеет одинаковую ширину (количество столбцов), но может варьироваться по высоте (количество строк), а некоторые из строк могут быть пустыми. Попытка настроить макрос в «Summary_Reports» wb, который откроет каждого из сотрудников wb, скопирует «колпачки» именованного диапазона и вставляет/вставляет только строки этого диапазона, содержащие данные в первом столбце, в лист «Отчет» в разделе «Summary_Reports» wb. Я предположил, что самый простой метод вставки будет состоять только в том, чтобы выбрать ячейку наверху и всегда вставлять туда эти строки, чтобы каждый сотрудник просто вставил над предыдущим, начиная с того же места. Таким образом, нет счета или поиска последней заполненной строки на листе. Сначала я попытался открыть «Jim.xls» и скопировать названный диапазон непосредственно из книги, но имел небольшой успех и много проблем с синтаксисом. Поэтому я закончил с приведенным ниже кодом, который вытаскивает лист сотрудников в «Summery_Reports», а затем копирует именованный диапазон из себя, а не другой wb. Вероятно, это приведет к удалению этих листов в конце.

То, что я начал с того, что происходит ниже, но подтверждение данных, которое я знаю, неверно. Исправьте меня, если я ошибаюсь, но он проверяет только верхнюю левую ячейку «шапки»; если есть содержимое, оно вставляет все «шапки», и если эта единственная ячейка пуста, она ничего не вставляет. Как исправить проверку, чтобы проверить первый столбец каждой строки, а также как мне заставить его просто дать мне строки с данными?

Кроме того, я знаю, что есть лучший способ получить данные о «шапках» непосредственно от каждого сотрудника wb, не импортируя сначала первую страницу. Если это можно сделать легко, я был бы очень заинтересован в любых советах в этом отношении.

Если вы достаточно любезны, чтобы помочь мне, пожалуйста, оставьте это как можно больше, поскольку мне действительно интересно узнать, что делает код, а не просто копировать и вставлять. Заранее спасибо.

Sub Import_Sheets() 
Application.Workbooks.Open ("jim.xls") 
Workbooks("jim.xls").Activate 
Sheets("Tasks").Copy After:=Workbooks("Summary_Report.xlsm").Sheets("Report") 
Application.Workbooks("Jim.xls").Close 

'Go to newly copied sheet and name it. 
ActiveSheet.Name = "jim" 

'Copy the "caps" named range. 
With Range("Caps") 
    If .Cells(1, 1).Value = "" Then 
    Else 
     Range("Caps").Select 
     Selection.Copy 
     Sheets("Report").Select 
     Range("B2").Select 
     Selection.Insert Shift:=xlDown 
    End If 
End With 
End Sub 

Answer 1

Комментариев Код:

Sub Import_Sheets() 

    'Declare variables 
    Dim wsDest As Worksheet 'This is the sheet that data will be pasted to 
    Dim rngCaps As Range 'This is used to determine if there is a named range "Caps" 
    Dim rngFound As Range 'This is used to loop through the first column in the named range "Caps" 
    Dim rngSearch As Range 'This is used to determine where to search 
    Dim rngCopy As Range 'This is used to store the rows with data that will be copied 
    Dim strFirst As String 'This is used to store the first cell address to prevent an infinite loop 
    Dim i As Long   'This is used to loop through the selected workbooks 

    'Create an "Open File" dialogue for the user to choose which files to import 
    With Application.FileDialog(msoFileDialogFilePicker) 
     .Filters.Clear       'Clear existing filters (if any) 
     .Filters.Add "Excel Files", "*.xls*" 'Filter for Excel files 
     .AllowMultiSelect = True    'Allow user to select multiple files at a time with Shift or Ctrl 

     If .Show = False Then Exit Sub 'Pressed cancel, exit macro 

     'The destination is this workbook, sheet 'Report' 
     Set wsDest = ActiveWorkbook.Sheets("Report") 

     'Turn off screenupdating. This prevents "Screen Flickering" and allows the code to run faster 
     Application.ScreenUpdating = False 

     'Begin loop through selected files 
     For i = 1 To .SelectedItems.Count 

      'Open a selected file 
      With Workbooks.Open(.SelectedItems(i)) 

       'Attempt to find a sheet named 'TimeEntry' with a named range "Caps" 
       On Error Resume Next 
       Set rngCaps = .Sheets("TimeEntry").Range("Caps") 
       On Error GoTo 0 'Remove the On Error Resume Next condition 

       'Was it able to set rngCaps successfully? 
       If Not rngCaps Is Nothing Then 
        'Yes, proceed to find rows with data 
        'Define rngSearch which will be used to find rows with data 
        Set rngSearch = Intersect(rngCaps, rngCaps.Cells(1).MergeArea.EntireColumn) 

        'Use a find loop to only get rows with data 
        'We can do this by utilizing the wildcard * 
        'The .Resize(, 1) will make sure we are only looking in the first column of rngCaps 
        Set rngFound = rngSearch.Find("*", rngSearch.Cells(rngSearch.Cells.Count), xlValues, xlWhole) 

        'Was there a cell found with data? 
        If Not rngFound Is Nothing Then 
         'Yes, record this first cell's address to prevent infinite loop 
         strFirst = rngFound.Address 

         'Also start storing the rows where data was found 
         Set rngCopy = rngFound 

         'Begin the find loop 
         Do 
          'Add found rows to the rngCopy variable 
          Set rngCopy = Union(rngCopy, rngFound) 

          'Advance loop to the next cell that contains data 
          Set rngFound = rngSearch.Find("*", rngFound, xlValues, xlWhole) 

         'Exit the loop when we are back to the first cell 
         Loop While rngFound.Address <> strFirst 

         'Copy the rows with data and paste them into the next available row in the destination worksheet 
         Intersect(rngCaps, rngCopy.EntireRow).Copy wsDest.Cells(wsDest.Rows.Count, "B").End(xlUp).Offset(1) 

         'Clear rngFound and rngCopy to get ready for next workbook 
         Set rngFound = Nothing 
         Set rngCopy = Nothing 
        End If 

        'Clear rngCaps to get ready for next workbook 
        Set rngCaps = Nothing 
       End If 

       'Close this opened workbook and don't save changes 
       .Close False 
      End With 

     'Advance to the next workbook that was selected 
     Next i 

     'Re-enable screen updating 
     Application.ScreenUpdating = True 

     'Object variable cleanup 
     Set wsDest = Nothing 

    End With 

End Sub