excel - 在主工作簿中复制范围和更新工作表

Question

我是 VBA 的新手，我正在做一个项目。我在互联网上搜索并设法使用其他人的示例将一些东西放在一起。基本思想是代码将用户选择的数据复制到单个主工作簿。这就是我到目前为止所拥有的；

Sub SelectOpenCopy()
Dim vaFiles As Variant
Dim i As Long
Dim DataBook As Workbook
Dim DataSheet As Worksheet

Application.ScreenUpdating = False
Application.DisplayAlerts = False

vaFiles = Application.GetOpenFilename(Title:="Select files", MultiSelect:=True)

If IsArray(vaFiles) Then
    For i = LBound(vaFiles) To UBound(vaFiles)
        Set DataBook = Workbooks.Open(FileName:=vaFiles(i))
        
        For Each DataSheet In ActiveWorkbook.Sheets
        DataSheet.Copy after:=ThisWorkbook.Worksheets(ThisWorkbook.Worksheets.Count)
        Next DataSheet
        
        DataBook.Close savechanges:=False
    Next i
End If

结束子

这样做的两个问题是：

1. 如果我再次运行代码并选择相同的文件，则会在主工作簿中制作新的工作表，这不是我想要的。如果这些工作表已经存在，我希望更新它们而不是制作新的。如果有帮助的话，所有需要复制到主文件的工作簿每个只有一个工作表，并且工作表名称也与其工作簿匹配。

2. 代码复制了所有数据，但我只需要一个设定范围（“A1:L1000”）。

我对 VBA 有很多不明白的地方，所以非常感谢任何和所有的帮助！

标签： excelvba

Answer 1

运行它时，不要忘记更改目标工作簿的路径。

Sub moveData()

'turn off unnecessary applications to make the macro run faster
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Application.EnableEvents = False

Dim target_wb As Workbook
Dim main_wb As Workbook
Dim file_sheet As Worksheet
Dim exists As Boolean
Dim next_empty_row As Long
Dim R As Range
Dim sheet_name As String

Set main_wb = ThisWorkbook

Set R = _
Application.InputBox("please select the data range:", "Kutools for Excel", , , , , , 8)

sheet_name = ActiveSheet.Name

R.Select
Selection.copy

'workbook path to paste in
Set target_wb = _
Workbooks.Open("/Users/user/Desktop/target.xlsx")

For Each file_sheet In target_wb.Sheets

        Application.DisplayAlerts = False
        
        If file_sheet.Name = main_wb.ActiveSheet.Name Then
             exists = True
             Exit For
        Else
            exists = False
        End If

Next file_sheet

If exists = False Then
    target_wb.Sheets.Add.Name = sheet_name
End If

next_empty_row = _
target_wb.Sheets(sheet_name).Cells(Rows.Count, 1).End(xlUp).Row + 1

target_wb.Sheets(sheet_name).Cells(next_empty_row, 1).PasteSpecial

target_wb.Save
target_wb.Close

'turn on applications
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Application.EnableEvents = False

End Sub