多步复制和粘贴 VBA 脚本

Question

我正在尝试从四个测试结果（每个不同的 Excel 文件）中提取数据（单元格），以便可以在模板中计算平均值。然后循环并在接下来的四个测试中执行相同的操作，但让 VBA 脚本将 y 单元格向下放置。我正在尝试执行以下操作，

1. 保护单元格，除了某些用于数据输入的单元格。- 完成
2. 按下插入的按钮后，运行 VBA 脚本，该脚本将复制和粘贴其他四个 Excel 工作簿中的某些单元格。完成
3. 复制和粘贴这四个之后，VBA 脚本循环但向下粘贴 y 个单元格。
4. 最后强制保存，因为这是一个公共模板，不希望更改。

我在使用 3-4 时遇到问题，到目前为止，我有以下代码...，但我还没有做太多这方面的工作来了解顺序/正确的代码命令。

到目前为止我有什么

第 1 步：完成

Sub ProtectSheetDataInput ()

Worksheets("DataInput").Cells.Locked = False
Worksheets("DataInput").Range("A1:B283,C1:N3").Locked = True
Worksheets("DataInput").Protect Password:="----coop", UserInterfaceOnly:=True

End Sub

第 2 步：完成

'Separate Macro    

Sub DataTransfer()

Dim w As Workbook 'Test_Location 1
Dim x As Workbook 'Test_Location 2
Dim y As Workbook 'Test_Location 3
Dim z As Workbook 'Test_Location 4
Dim Alpha As Workbook 'Template

Set w = Workbooks.Open("C:\Users\aholiday\Desktop\FRF_Data_Macro_Insert_Test\location_1.xls")
Set x = Workbooks.Open("C:\Users\aholiday\Desktop\FRF_Data_Macro_Insert_Test\location_2.xls")
Set y = Workbooks.Open("C:\Users\aholiday\Desktop\FRF_Data_Macro_Insert_Test\location_3.xls")
Set z = Workbooks.Open("C:\Users\aholiday\Desktop\FRF_Data_Macro_Insert_Test\location_4.xls")
Set Alpha = Workbooks("FRF_Data_Sheet_Template.xlsm")

    Alpha.Sheets("DataInput").Range("C4:E8").Value = w.Sheets("Data").Range("I3:K7").Value
    Alpha.Sheets("DataInput").Range("F4:H8").Value = x.Sheets("Data").Range("I3:K7").Value
    Alpha.Sheets("DataInput").Range("I4:K8").Value = y.Sheets("Data").Range("I3:K7").Value
    Alpha.Sheets("DataInput").Range("L4:N8").Value = z.Sheets("Data").Range("I3:K7").Value

    w.Close False
    x.Close False
    y.Close False
    z.Close False

End Sub

第 3 步更新： 累了，如果在 C 列中找到空白，则粘贴...不起作用。

处出错

 If Columns("C").Value = "" Then 

“类型不匹配”

Sub DataTransfer()

Application.ScreenUpdating = False
Dim w As Workbook 'Test_Location 1
Dim x As Workbook 'Test_Location 2
Dim y As Workbook 'Test_Location 3
Dim z As Workbook 'Test_Location 4
Dim Alpha As Workbook 'Template
Dim Emptyrow As Long 'Next Empty Row

    Set w = Workbooks.Open("C:\Users\aholiday\Desktop\FRF_Data_Macro_Insert_Test\location_1.xls")
    Set x = Workbooks.Open("C:\Users\aholiday\Desktop\FRF_Data_Macro_Insert_Test\location_2.xls")
    Set y = Workbooks.Open("C:\Users\aholiday\Desktop\FRF_Data_Macro_Insert_Test\location_3.xls")
    Set z = Workbooks.Open("C:\Users\aholiday\Desktop\FRF_Data_Macro_Insert_Test\location_4.xls")
    Set Alpha = Workbooks("FRF_Data_Sheet_Template.xlsm")

        If Columns("C").Value = "" Then
            Alpha.Sheets("DataInput").Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Value = w.Sheets("Data").Range("I3:K7").Value
            Alpha.Sheets("DataInput").Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Value = x.Sheets("Data").Range("I3:K7").Value
            Alpha.Sheets("DataInput").Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Value = y.Sheets("Data").Range("I3:K7").Value
            Alpha.Sheets("DataInput").Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Value = z.Sheets("Data").Range("I3:K7").Value

            w.Close False
            x.Close False
            y.Close False
            z.Close False
        End If
Application.ScreenUpdating = True
End Sub

然后我尝试了一种不同的方法，我让它在 2 个工作表之间工作，但我无法让它在多个工作簿之间工作。我得到'运行时错误'9'下标超出这一行的范围。

Alpha.Sheets(DataInput).Activate

'

Sub DataTransfer()

Application.ScreenUpdating = False
Dim w As Workbook 'Test_Location 1
Dim x As Workbook 'Test_Location 2
Dim y As Workbook 'Test_Location 3
Dim z As Workbook 'Test_Location 4
Dim Alpha As Workbook 'Template
Dim Emptyrow As Range

    Set w = Workbooks.Open("C:\Users\aholiday\Desktop\FRF_Data_Macro_Insert_Test\location_1.xls")
    Set x = Workbooks.Open("C:\Users\aholiday\Desktop\FRF_Data_Macro_Insert_Test\location_2.xls")
    Set y = Workbooks.Open("C:\Users\aholiday\Desktop\FRF_Data_Macro_Insert_Test\location_3.xls")
    Set z = Workbooks.Open("C:\Users\aholiday\Desktop\FRF_Data_Macro_Insert_Test\location_4.xls")
    Set Alpha = Workbooks("FRF_Data_Sheet_Template.xlsm")
    Set EmptyrowC = Range("C" & Sheets("DataInput").UsedRange.Rows.Count + 1)
    Set EmptyrowF = Range("F" & Sheets("DataInput").UsedRange.Rows.Count + 1)
    Set EmptyrowI = Range("I" & Sheets("DataInput").UsedRange.Rows.Count + 1)
    Set EmptyrowL = Range("L" & Sheets("DataInput").UsedRange.Rows.Count + 1)

        w.Sheets("Data").Range("I3:K7").Copy
        Alpha.Sheets(DataInput).Active
            NextRow.PasteSpecial Paste:=xlValues, Transpose:=False
            Application.CutCopyMode = False
            Set NextRow = Nothing
        x.Sheets("Data").Range("I3:K7").Copy
            Alpha.Sheets(DataInput).Active
            NextRow.PasteSpecial Paste:=xlValues, Transpose:=False
            Application.CutCopyMode = False
            Set NextRow = Nothing
        y.Sheets("Data").Range("I3:K7").Copy
            Alpha.Sheets(DataInput).Active
            NextRow.PasteSpecial Paste:=xlValues, Transpose:=False
            Application.CutCopyMode = False
            Set NextRow = Nothing
        z.Sheets("Data").Range("I3:K7").Copy
            Alpha.Sheets(DataInput).Active
            NextRow.PasteSpecial Paste:=xlValues, Transpose:=False
            Application.CutCopyMode = False
            Set NextRow = Nothing

        w.Close False
        x.Close False
        y.Close False
        z.Close False

Application.ScreenUpdating = True
End Sub

Answer 1

这个不起作用，它会打开输出但不会复制单元格

我没有看到你打开 X 工作簿。

如果y.Sheets("Sheet1") 中的单元格已解锁，这对我来说很好用。

还要注意在两端使用.Value。

Sub DataTransfer()
    Dim x As Workbook, y As Workbook

    Set y = Workbooks.Open("C:\Users\aholiday\Desktop\Test_output.xlsm")
    Set x = Workbooks.Open("C:\Blah Blah\Blah.xlsm") '<~~ Change as Applicable

    y.Sheets("Sheet1").Range("A1:F5").Value = x.Sheets("InputSheet").Range("A1:F5").Value
End Sub

Answer 2

改为复制到目的地。

y.Sheets("Sheet1").Range("A1:F5").Copy _           
   destination:=x.Sheets("InputSheet").Range("A1:F5")