当前位置：首页 > news >正文

vb copy target range

news 2026/6/16 19:28:25

Sub BatchMergeExcelFiles()
Dim sourceFolder As String
Dim newWorkbook As Workbook
Dim sourceWorkbook As Workbook
Dim fileDialog As fileDialog
Dim targetRow1 As Long ' new.xlsx Sheet1的目标粘贴行
Dim targetRow2 As Long ' new.xlsx Sheet2的目标粘贴行

' 1. 选择目标文件夹（手动选择，避免硬编码路径）
Set fileDialog = Application.fileDialog(msoFileDialogFolderPicker)
With fileDialog
.Title = "请选择要遍历的文件夹"
If .Show <> -1 Then Exit Sub
sourceFolder = .SelectedItems(1) & "\"
End If

' 2. 创建新工作簿 new.xlsx
Set newWorkbook = Workbooks.Add
newWorkbook.SaveAs Filename:=sourceFolder & "new.xlsx", FileFormat:=xlOpenXMLWorkbook

' 初始化目标粘贴行（从第1行开始）
targetRow1 = 1
targetRow2 = 1

' 3. 遍历文件夹内所有xlsx文件
Dim fileName As String
fileName = Dir(sourceFolder & "*.xlsx")

Application.ScreenUpdating = False ' 关闭屏幕更新，提升效率
Application.DisplayAlerts = False ' 关闭弹窗提示

Do While fileName <> ""
' 跳过新建的new.xlsx，避免自循环
If fileName <> "new.xlsx" Then
' 打开源文件
Set sourceWorkbook = Workbooks.Open(sourceFolder & fileName)

' ========== 复制 Sheet1!B7:G8 到 new.xlsx Sheet1 ==========
With sourceWorkbook.Worksheets("Sheet1")
.Range("B7:G8").Copy
newWorkbook.Worksheets(1).Range("A" & targetRow1).PasteSpecial Paste:=xlPasteValuesAndNumberFormats
End With
targetRow1 = targetRow1 + 2 ' 每次复制2行，目标行递增2

' ========== 复制 Sheet1!B51:G58 到 new.xlsx Sheet2 ==========
With sourceWorkbook.Worksheets("Sheet1")
.Range("B51:G58").Copy
newWorkbook.Worksheets(2).Range("A" & targetRow2).PasteSpecial Paste:=xlPasteValuesAndNumberFormats
End With
targetRow2 = targetRow2 + 8 ' 每次复制8行，目标行递增8

' 关闭源文件，不保存修改
sourceWorkbook.Close SaveChanges:=False
End If

' 读取下一个文件
fileName = Dir
Loop

' 收尾操作
Application.CutCopyMode = False
Application.ScreenUpdating = True
Application.DisplayAlerts = True
newWorkbook.Save ' 保存new.xlsx
newWorkbook.Close

MsgBox "批量合并完成！" & vbCrLf & "新文件路径：" & sourceFolder & "new.xlsx", vbInformation

' 释放对象
Set sourceWorkbook = Nothing
Set newWorkbook = Nothing
Set fileDialog = Nothing
End Sub