Question

我正在尝试从四个测试结果（每个不同的excel文件）中提取数据（单元格），以便可以在模板中计算平均值。然后循环并在接下来的四个测试中做同样的事情，但让VBA脚本放下y个单元格。我正在努力做到以下几点，

保护除某些细胞以外的细胞进行数据输入.-完成
按下插入的按钮后，运行一个VBA脚本，该脚本将复制并粘贴其他四个excel工作簿中的某些单元格。完成
复制并粘贴这四个之后，要使VBA脚本循环，但要将y个单元格粘贴下来。
最后强制保存，因为这是一个公共模板，不希望它被更改。

我遇到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

然后我尝试了一种不同的方法，我让它在两个工作表之间工作，但我不能让它在多个工作簿之间工作。我得到'Runtime Error'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

复制到目的地。

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

Answer 2

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

我没有看到你打开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

多步复制并粘贴VBA脚本

2 个答案: