Excel VBA: Copy and Paste Specific Cell from Another Workbook Loop

Question

I am trying to copy specific 21 cells and paste them into a destination workbook. The cells are not in order on the source workbook but will be on the destination. I need to loop through all the files in the folder. The same cells will be pulled from each of the sources and pasted in same columns for the destination just proceeding row. I have tried many versions of active copy and pasting and always receive errors like 1004.

This current code returns overflow error 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

any help or recommendations to try something completely different is appreciated.

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

Hi Not sure if I get correctly what you are trying to achieve, but this works for me without any error message

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

this is what i went with and it works

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