Copy Paste in a Loop

[Niraj Baraili]

Hi All,

I am trying to consolidate different files with same heading which are dumped
in a same folder to a Consolidated file. For this i have written codes as below.
The codes are working fine untill there is no blank file in source folder.
If there is a blank file then the codes copy the data from previous file
two times. For example, Generator ID 1, Generator ID 2, Generator ID 3,
Generator ID 4, Generator ID 5 are source file. Generator ID 4 is blank.
When macro runs, it copies the data from the Generator ID 3 two times.If i
remove this blank file, the code runs perfectly.

Any help is appreciated.

Sub LoopthroughDirectory()
Dim myFile As String
Dim erow
Dim filepath As String
Dim Destfile As String
Dim myFileName As String
myFileName = "Consolidated File.xlsx"
Destfile = "D:\Consolidation\Output\"
filepath = "D:\Consolidation\Input\"
myFile = Dir(filepath)
Workbooks.Open (Destfile & "\" & myFileName)

Application.ScreenUpdating = False
Application.DisplayAlerts = False

Do While Len(myFile) > 0
 
    Workbooks.Open (filepath & myFile)
    'If There is no data in file then go the next file
    If Range("A2").Value = "" Then
    ActiveWorkbook.Close
    Else
    Range("A2").Select
    Range(Selection, Selection.End(xlToRight)).Select
    Range(Selection, Selection.End(xlDown)).Select
    Selection.Copy
    ActiveWorkbook.Close
    End If
         
    'erow = Sheet1.Cells(Rows.Count, 1).End(xlUp).Row + 1
    erow = Cells(Rows.Count, 1).End(xlUp).Row + 1
 
    ActiveSheet.Paste Destination:=Worksheets("sheet1").Range(Cells(erow, 1), Cells(erow, 6))
    Columns.AutoFit
     
    myFile = Dir
 
Loop
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub

 

[Niraj Baraili]

Unable to upload more than 3 files. Here are the rest files.

 

[mohadin]

HI
I DID FIND ONE BUG
HOOP IT OK WITH YOU
PLEASE JUST MAKE THIS CHANGES

Sub LoopthroughDirectory()
Dim myFile As String
Dim erow
Dim filepath As String
Dim Destfile As String
Dim myFileName As String
myFileName = "Consolidated File.xlsx"
Destfile = "D:\Consolidation\Output\"
filepath = "D:\Consolidation\Input\"
myFile = Dir(filepath)
Workbooks.Open (Destfile & "\" & myFileName)

Application.ScreenUpdating = False
Application.DisplayAlerts = False

Do While Len(myFile) > 0

Workbooks.Open (filepath & myFile)
'If There is no data in file then go the next file
If Range("A2").Value = "" Then
ActiveWorkbook.Close
GO TO 1
Else
Range("A2").Select
Range(Selection, Selection.End(xlToRight)).Select
Range(Selection, Selection.End(xlDown)).Select
Selection.Copy
ActiveWorkbook.Close
End If

'erow = Sheet1.Cells(Rows.Count, 1).End(xlUp).Row + 1
erow = Cells(Rows.Count, 1).End(xlUp).Row + 1

ActiveSheet.Paste Destination:=Worksheets("sheet1").Range(Cells(erow, 1), Cells(erow, 6))
Columns.AutoFit

myFile = Dir

Loop
1 Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub

 

[Niraj Baraili]

Hi Mohadin,

Thanks for the reply. Could you please elaborate where exactly the bug is ?

 

[mohadin]

Option Explicit

Sub LoopthroughDirectory()
    Dim myFile As String
    Dim erow
    Dim filepath As String
    Dim Destfile As String
    Dim myFileName As String
    myFileName = "Consolidated File.xlsx"
    Destfile = "D:\Consolidation\Output\"
    filepath = "D:\Consolidation\Input\"
    myFile = Dir(filepath)
    Workbooks.Open (Destfile & "\" & myFileName)

    Application.ScreenUpdating = False
    Application.DisplayAlerts = False

    Do While Len(myFile) > 0

        Workbooks.Open (filepath & myFile)
        'If There is no data in file then go the next file
        If Range("A2").Value = "" Then
            ActiveWorkbook.Close
            GoTo 1
        Else
            Range("A2").Select
            Range(Selection, Selection.End(xlToRight)).Select
            Range(Selection, Selection.End(xlDown)).Select
            Selection.Copy
            ActiveWorkbook.Close
        End If

        'erow = Sheet1.Cells(Rows.Count, 1).End(xlUp).Row + 1
        erow = Cells(Rows.Count, 1).End(xlUp).Row + 1

        ActiveSheet.Paste Destination:=Worksheets("sheet1").Range(Cells(erow, 1), Cells(erow, 6))
        Columns.AutoFit

        myFile = Dir

    Loop
1  Application.ScreenUpdating = True
    Application.DisplayAlerts = True
End Sub

Simply when the workbook in empty (Range a2="") it should end the sub
assuming that the last workbook in empty
see the red lines
in your code it ends the if statement; then it go to paste again.
Please do accept this arrangement for your code easier for debug
Regards

 

[Niraj Baraili]

Still i am clueless. Just tried the above code. It's copying data from File 1 to 3. Next file are not copied.

 

[mohadin]

sorry
please try to modify this part of your code
the end if
i think it will be ok
tel me if you like it
regards

Do While Len(myFile) > 0

    Workbooks.Open (filepath & myFile)
    'If There is no data in file then go the next file
    If Range("A2").Value = "" Then
    ActiveWorkbook.Close
    Else
    Range("A2").Select
    Range(Selection, Selection.End(xlToRight)).Select
    Range(Selection, Selection.End(xlDown)).Select
    Selection.Copy
    ActiveWorkbook.Close

  '  End If 
    'erow = Sheet1.Cells(Rows.Count, 1).End(xlUp).Row + 1
    erow = Cells(Rows.Count, 1).End(xlUp).Row + 1

    ActiveSheet.Paste Destination:=Worksheets("sheet1").Range(Cells(erow, 1), Cells(erow, 6))
    Columns.AutoFit
        End If
    myFile = Dir

Loop

 

[Niraj Baraili]

Hi Mohadin,

Thank you very much for the guidance. Now code is working fine.

 

[mohadin]

You welcome