Avoid Activation

[duncan1970]

Sub CompareSingle1()
Application.ScreenUpdating = False
Dim csvdir As String
Dim xlsxdir As String
Dim windir As String
ChDir "C:\Users\EricB\Desktop"
Workbooks.Open Filename:="C:\Users\EricB\Desktop\Singlecopy.xlsx"
xlsxdir = "C:\Users\EricB\Desktop\Single2\jun17"
ChDir xlsxdir
For i = 1 To 15000
Workbooks.Open Filename:=xlsxdir & "\jun17_" & i & ".xlsx"
Range("G1").Select
Selection.Copy
Windows("singlecopy").Activate
Range("A1").Select
Cells(Rows.Count, "b").End(xlUp).Offset(1, 0).Select
ActiveSheet.Paste
Workbooks(3).Activate
ActiveWorkbook.Close

Next i
End Sub

 

[bjurney]

Welcome to the board. Can you give a description of what you would like to do. This just looks like it opens a file, copies cell G1 and pastes it in the first blank space in your other workbook 15,000 times. Not sure if you need a workbook to open and close that many times, but we can see what we can come up with.

 

[VoG]

Try like this

Sub CompareSingle1()
Application.ScreenUpdating = False
Dim xlsxdir As String
ChDir "C:\Users\EricB\Desktop"
Workbooks.Open Filename:="C:\Users\EricB\Desktop\Singlecopy.xlsx"
xlsxdir = "C:\Users\EricB\Desktop\Single2\jun17"
ChDir xlsxdir
For i = 1 To 15000
    Workbooks.Open Filename:=xlsxdir & "\jun17_" & i & ".xlsx"
    Range("G1").Copy Destination:=Workbooks("singlecopy.xlsx").Sheets(1).Range("B" & Rows.Count).End(xlUp).Offset(1)
    ActiveWorkbook.Close
Next i
Application.ScreenUpdating = True
End Sub

 

[duncan1970]

Thanks for the reply. Your code worked great!

 

[VoG]

You are welcome. That code must still take an age to run though