Excelmacros仅合并文件夹中多个工作簿的每个第一个工作表中的几个单元格
我使用下面的visual basic来select一个文件夹中的多个excel工作簿，并将它们合并到我的活动工作簿的第二个工作表中。
在实际的代码示例中，它将“按原样”合并整个范围，包括所有列，行和空白单元格。 我只需要使用选定工作簿中第一个工作表中的几个单元格 （B3，B5，B7和E48）的复制数据，并将其粘贴到第二个工作表上的每个合并工作簿中的一行中 。
如何防止macros将所有这些不必要的数据写入目标表单？ 或者，至less，如何将B3：E48的范围合并到目标工作表中的一行？
Private Declare Function SetCurrentDirectoryA Lib _ "kernel32" (ByVal lpPathName As String) As Long Sub ChDirNet(szPath As String) SetCurrentDirectoryA szPath End Sub Sub MergeSpecificWorkbooks() Dim MyPath As String Dim SourceRcount As Long, FNum As Long Dim mybook As Workbook, BaseWks As Worksheet Dim sourceRange As Range, destrange As Range Dim rnum As Long, CalcMode As Long Dim SaveDriveDir As String Dim FName As Variant ' Set application properties. With Application CalcMode = .Calculation .Calculation = xlCalculationManual .ScreenUpdating = False .EnableEvents = False End With SaveDriveDir = CurDir ' Change this to the path\folder location of the files. ChDirNet "H:\xlstest" FName = Application.GetOpenFilename(filefilter:="Excel Files (*.xl*), *.xl*", _ MultiSelect:=True) If IsArray(FName) Then ' Add a new workbook with one sheet. 'Set BaseWks = Workbooks.Add(xlWBATWorksheet).Worksheets(1) 'prevent prompting new workbook, write data in active sheet number two Set BaseWks = ActiveWorkbook.Worksheets(2) rnum = 1 ' Loop through all files in the myFiles array. For FNum = LBound(FName) To UBound(FName) Set mybook = Nothing On Error Resume Next Set mybook = Workbooks.Open(FName(FNum)) On Error GoTo 0 If Not mybook Is Nothing Then On Error Resume Next With mybook.Worksheets(1) Set sourceRange = .Range("B5:E48") End With If Err.Number > 0 Then Err.Clear Set sourceRange = Nothing Else ' If the source range uses all columns then ' skip this file. If sourceRange.Columns.Count >= BaseWks.Columns.Count Then Set sourceRange = Nothing End If End If On Error GoTo 0 If Not sourceRange Is Nothing Then SourceRcount = sourceRange.Rows.Count If rnum + SourceRcount >= BaseWks.Rows.Count Then MsgBox "There are not enough rows in the target worksheet." BaseWks.Columns.AutoFit mybook.Close savechanges:=False GoTo ExitTheSub Else ' Copy the file name in column A. With sourceRange BaseWks.Cells(rnum, "A"). _ Resize(.Rows.Count).Value = FName(FNum) End With ' Set the destination range. Set destrange = BaseWks.Range("B" & rnum) ' Copy the values from the source range ' to the destination range. With sourceRange Set destrange = destrange. _ Resize(.Rows.Count, .Columns.Count) End With destrange.Value = sourceRange.Value rnum = rnum + SourceRcount End If End If mybook.Close savechanges:=False End If Next FNum BaseWks.Columns.AutoFit End If ExitTheSub: ' Restore the application properties. With Application .ScreenUpdating = True .EnableEvents = True .Calculation = CalcMode End With ChDirNet SaveDriveDir End Sub 此代码基于Ron de Bruin的合并示例 ，实际上没有任何其他相关的互联网源提供解决scheme。
这会给你一些关于如何创build一个非连续的范围，以及如何遍历和复制它的值到一个单一的行的想法。
Sub Tester() Dim a As Range, c As Range Dim rngSrc As Range, rngDest As Range Dim x As Long Set rngSrc = ActiveSheet.Range("B3,B5,B7,E48") Set rngDest = ActiveSheet.Range("A1") x = 0 For Each a In rngSrc.Areas For Each c In a.Cells x = x + 1 rngDest.Offset(0, x - 1).Value = c.Value Next c Next a End Sub