Excel VBA：从另一个工作簿循环复制和粘贴特定单元格

Question

我正在尝试复制特定的 21 个单元格并将它们粘贴到目标工作簿中。 单元格在源工作簿上不按顺序排列，但将在目标位置上。我需要遍历文件夹中的所有文件。将从每个源中提取相同的单元格并将其粘贴到目标行的相同列中。我尝试了许多版本的主动复制和粘贴，总是收到类似 1004 的错误。

此当前代码返回溢出错误 6。

Sub loopit()

Dim myfolder As String
Dim myfile As String
Dim i As Integer

Dim x As Integer
Dim y As Integer


myfolder = "C:\\path\"
myfile = Dir(myfolder & "*.xls")

i = 2

Do While myfile <> ""
Workbooks.Open Filename:=myfolder & myfile, UpdateLinks:=0
    x = Sheets("Suppressed").Range("H332").Value
    y = Sheets("Suppressed").Range("H335").Value
ActiveWorkbook.Close savechanges:=False

Windows("cook_data.xlsm").Activate
Sheets("cook").Select
Cells(i, 2) = x
Cells(i, 4) = y

i = i + 1

myfile = Dir
Loop

End Sub

感谢任何帮助或建议尝试完全不同的东西。

Answer 1

嗨，我不确定我是否正确理解了您想要实现的目标，但这对我有用，没有任何错误消息

Sub loopit()

Dim myfolder As String
Dim myfile As String
Dim wb As Workbook, ws As Worksheet
Set wb = ThisWorkbook
Set ws = wb.Sheets("cook")
Dim i As Integer

Dim x As Integer
Dim y As Integer

myfolder = "C:\\path\"
myfile = Dir(myfolder & "*.xls")

i = 2

Do While myfile <> ""
    Workbooks.Open Filename:=myfolder & myfile, UpdateLinks:=0
        x = Sheets("Suppressed").Range("H332").Value
        y = Sheets("Suppressed").Range("H335").Value
    ActiveWorkbook.Close savechanges:=False

    ws.Activate
    ws.Cells(i, 2) = x
    ws.Cells(i, 4) = y

    i = i + 1

    myfile = Dir
Loop

End Sub

Answer 2

Sub looper()

Dim myFolder As String
Dim myFile As String
Dim wbX As Workbook
Dim ws As Worksheet
Dim i As Long

'assign current sheet to variable
Set ws = ActiveWorkbook.Sheets("cook")

'assign directory (use only a single backslash after the colon)
myFolder = "C:\path\"
myFile = Dir(myFolder & "*.xls")

'initialize counter
i = 2

'turn off screen updating
Application.ScreenUpdating = False

'begin loop
Do While myFile <> ""

    'open a file
    Workbooks.Open Filename:=myFolder & myFile, UpdateLinks:=0

    'assign the file to a variable
    Set wbX = ActiveWorkbook

    'directly assign values from opened file to original file
    ws.Cells(i, 2).Formula = wbX.Sheets("Suppressed").Range("H332").Value
    ws.Cells(i, 4).Formula = wbX.Sheets("Suppressed").Range("H335").Value

    'close opened file
    ActiveWorkbook.Close SaveChanges:=False

    'increase counter
    i = i + 1

    'update file list
    myFile = Dir

Loop

'turn screenupdating back on
Application.ScreenUpdating = True

End Sub

Answer 3

这就是我所使用的，它有效

Sub iterateit()

Dim myfolder As String
Dim myFile As String
Dim i As Integer

Dim x As Integer
Dim y As Integer
Dim z As String

Application.ScreenUpdating = False

myfolder = "\\path\"
myFile = Dir(myfolder & "*.xls")

i = 2

Do While myFile <> ""
    Workbooks.Open Filename:=(myfolder & myFile), UpdateLinks:=0
    x = ActiveWorkbook.Sheets("Suppressed").Range("h332").Value
    y = ActiveWorkbook.Sheets("Suppressed").Range("h333").Value
    z = myFile


    ActiveWorkbook.Close SaveChanges:=False

    Windows("cook.xltm").Activate
    ActiveWorkbook.Sheets("cook").Cells(i, 2).Value = x
    ActiveWorkbook.Sheets("cook").Cells(i, 3).Value = y
    ActiveWorkbook.Sheets("cook").Cells(i, 4) = z

    myFile = Dir
    i = i + 1
Loop

ActiveWorkbook.Worksheets("cook").Sort.SortFields.Clear
ActiveWorkbook.Worksheets("cook").Sort.SortFields.Add Key:=Range("D1"), _
    SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
With ActiveWorkbook.Worksheets("cook").Sort
    .SetRange Range("A2:D67")
    .Header = xlNo
    .MatchCase = False
    .Orientation = xlTopToBottom
    .SortMethod = xlPinYin
    .Apply
End With
End Sub