合并工作簿VBA代码修改需求：将指定区域内容插入C列

我帮你调整了VBA代码，完美实现提取目标文件中B2:D13区域内容并插入新工作簿C列，同时将文件名写入对应行A列的需求。下面是修改后的完整代码，关键修改点我也单独列出来了，方便你理解：

关键修改点 #

• 提取区域从原代码的Range("A1:C5")改为Range("B2:D13")，精准匹配你需要的目标区域
• 目标粘贴区域从原来的B列调整为C列，对应修改了destrange的起始位置为BaseWks.Range("C" & rnum)
• 保留了文件名写入A列的逻辑，确保提取内容的行数和文件名对应的行数完全匹配

修改后的完整VBA代码 #

Sub MergeCode1()
 Dim BaseWks As Worksheet
 Dim rnum As Long
 Dim CalcMode As Long
 Dim MySplit As Variant
 Dim FileInMyFiles As Long
 Dim Mybook As Workbook
 Dim sourceRange As Range
 Dim destrange As Range
 Dim SourceRcount As Long
 'Add a new workbook with one sheet
 Set BaseWks = Workbooks.Add(xlWBATWorksheet).Worksheets(1)
 BaseWks.Range("A1").Font.Size = 36
 BaseWks.Range("A1").Value = "Please Wait"
 rnum = 3
 'Change ScreenUpdating, Calculation and EnableEvents
 With Application
 CalcMode = .Calculation
 .Calculation = xlCalculationManual
 .ScreenUpdating = False
 .EnableEvents = False
 End With
 'Clear MyFiles to be sure that it not return old info if no files are found
 MyFiles = ""
 'Get the files, set the level of folders and extension in the code line below
 Call GetFilesOnMacWithOrWithoutSubfolders(Level:=1, ExtChoice:=0, FileFilterOption:=0, FileNameFilterStr:="")
 'Level : 1= Only the files in the folder you select, 2 to ? levels of subfolders
 'ExtChoice : 0=(xls|xlsx|xlsm|xlsb), 1=xls , 2=xlsx, 3=xlsm, 4=xlsb, 5=csv, 6=txt, 7=all files, 8=(xlsx|xlsm|xlsb), 9=(csv|txt)
 'FileFilterOption : 0=No Filter, 1=Begins, 2=Ends, 3=Contains
 'FileNameFilterStr : Search string used when FileFilterOption = 1, 2 or 3
 ' Work with the files if MyFiles is not empty.
 If MyFiles <> "" Then
 MySplit = Split(MyFiles, Chr(13))
 For FileInMyFiles = LBound(MySplit) To UBound(MySplit)
 Set Mybook = Nothing
 On Error Resume Next
 Set Mybook = Workbooks.Open(MySplit(FileInMyFiles))
 On Error GoTo 0
 If Not Mybook Is Nothing Then
 On Error Resume Next
 With Mybook.Worksheets(1)
 ' 修改提取区域为B2:D13
 Set sourceRange = .Range("B2:D13")
 End With
 If Err.Number > 0 Then
 Err.Clear
 Set sourceRange = Nothing
 Else
 'if SourceRange use 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 "Sorry there are not enough rows in the sheet"
 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 = MySplit(FileInMyFiles)
 End With
 ' 修改目标粘贴区域为C列
 Set destrange = BaseWks.Range("C" & rnum)
 'we copy the values from the sourceRange to the destrange
 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 FileInMyFiles
 BaseWks.Columns.AutoFit
 End If
 ExitTheSub:
 BaseWks.Range("A1").Value = "Ready"
 'Restore ScreenUpdating, Calculation and EnableEvents
 With Application
 .ScreenUpdating = True
 .EnableEvents = True
 .Calculation = CalcMode
 End With
 End Sub

内容的提问来源于stack exchange，提问作者Dantino Esposito