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 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 2

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

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 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

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

3 个答案: