Excel VBA从另一个名为range的工作簿中提取非空行

VBA技能薄弱的网站新手。 希望我能find一些我一直在挣扎的东西。 我发现了很多很接近的例子，似乎不能把它们结合在一起。 我正在使用Excel 2007.我有一个“Summary_Reports”WB，以及由员工命名的其他几个工作簿（例如“Jim.xls”，“bob.xls”等）。 每个员工工作簿都有一个来自工作表“任务”的命名范围“上限”。 这个在每个员工wb中的命名范围是相同的宽度（列数），但可以在高度（行数）上有所不同，有些行可能是空的。 尝试在“Summary_Reports”wb中设置一个将打开每个员工wb的macros，复制命名的范围“caps”，并将只包含第一列数据的范围的行插入/粘贴到“Report”表在“Summary_Reports”中。 我认为最简单的粘贴方法就是在顶部select一个单元格，并始终在那里插入这些行，这样，每个员工就可以在同一位置插入上一个单元格。 这种方式不计算或寻找工作表上最后填充的行。 我首先尝试打开“Jim.xls”，并直接从工作簿中复制命名的范围，但是在语法上很less成功，而且很麻烦。 所以我结束了下面的代码拉雇员表到“Summery_Reports”，然后从本身而不是另一个wb复制命名的范围。 最后可能会最终删除这些表单。

我在下面开始的工作，但我知道的数据validation是不正确的。 纠正我，如果我错了，但它只是检查右上angular左上方的单元格“帽” 如果有内容，则粘贴所有的“caps”，如果单个单元格是空的，则不粘贴任何内容。 我如何纠正validation，以检查每一行的第一列，也是如何得到它只给我的数据行？

另外，我知道还有一种更好的方法可以直接从每个员工wb获取“caps”数据，而不必先导入表格。 如果这样做容易，我会对这方面的任何build议非常感兴趣。

如果你善意的帮助我，请尽可能地减less它，因为我真的有兴趣知道代码的function，而不仅仅是复制和粘贴。 先谢谢你。

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