Excel VBA從另一個名爲範圍的工作簿中提取非空行

Question

VBA技能較弱的站點的新手。希望我可以找到一些我一直在努力掙扎的事情。我發現很多很接近的例子，似乎不能將它們結合在一起。我正在使用Excel 2007.我有一個「Summary_Reports」WB，以及由員工命名的其他幾個工作簿（例如「Jim.xls」，「bob.xls」等）。每個員工工作簿都有一個來自工作表「任務」的命名範圍「上限」。這個在每個員工wb中的命名範圍是相同的寬度（列數），但可以在高度（行數）上有所不同，並且某些行可能爲空。嘗試在「Summary_Reports」wb中設置一個將打開每個員工wb的宏，複製命名的範圍「caps」，並將只包含第一列數據的該範圍的行插入/粘貼到「Report」表單在「Summary_Reports」wb中。我認爲最簡單的粘貼方法就是在頂部選取一個單元格，並始終在那裏插入這些行，這樣每個員工就會從同一位置插入到上一個單元格上方。這樣就不會計算或查找表單上最後一個已填充的行。我首先嚐試打開「Jim.xls」，然後直接從工作簿中複製命名的範圍，但是在語法上沒有什麼成功和很多麻煩。因此，我最終得到了下面的代碼，將僱員表拉入「Summery_Reports」，然後從本身複製命名範圍而不是另一個wb。最後可能會最終刪除這些表單。

我從下面開始有點作品，但我知道的數據驗證不正確。糾正我，如果我錯了，但它只是檢查右上角的左上角的單元格「帽」;如果有內容，它會粘貼所有「caps」，如果該單元格爲空，則不會粘貼任何內容。我該如何糾正驗證以檢查每一行的第一列，以及如何才能讓它獲得數據行？

另外，我知道有一種更好的方法可以直接從每個員工wb獲取「caps」數據，而無需先導入表格。如果這可以輕鬆完成，我會對這方面的任何建議非常感興趣。

如果您對我有幫助，請儘可能地減少它，因爲我真的很瞭解代碼的功能，而不僅僅是複製和粘貼。先謝謝你。

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