DIR Do While Loop not working as expected

[Doghouse308]

I am trying to open all of the files that meet a search criteria and are in a specified folder. I want to copy and paste the contents of certain worksheets into one worksheet that will contain the combined data of the sheets. I had it working earlier and now it is copying the contents of each worksheet into the correct work sheet in the combined file, but the data in the second file is overwriting the data that was previously copied from the first file. Subsequent files do not overwrite the previous data. This is the portion of the macro responsible for the copy and paste portion of the overall macro.

[/COLOR]Sub copyData()
    Dim fileToOpen As Variant
    Dim path As Variant
    Dim masterWB As Workbook
    Dim currentWorkbook As Workbook
    Dim currentSheet As Worksheet
    Dim startCell As Range
   
    
    
    Set masterWB = ThisWorkbook
    
    
    path = masterWB.Sheets("Support").Range("C6").Value
    Do While path = VBA.Constants.vbNullString
    
        MsgBox "Select Location of the Individual Master Files"
        Call SelectPath
        
    Loop
   
    'open individual master files, copy data and close files
    fileToOpen = Dir(path & "*master*xls?")


    Do Until fileToOpen = vbNullString
        DoEvents
        
        Set currentWorkbook = Workbooks.Open(path & fileToOpen)
        currentWorkbook.Activate
        Set currentSheet = currentWorkbook.Sheets("Master Schedule")
        currentSheet.Activate
        Set startCell = currentSheet.Range("A2")
        startCell.EntireRow.Select
        currentSheet.Range(Selection, Selection.End(xlDown).End(xlToRight)).Select
        Selection.Copy
        masterWB.Activate
        masterWB.Sheets("Master Schedule").Activate
        masterWB.Sheets("Master Schedule").Range("A2").Select
        Range(Selection, Selection.End(xlDown)).Select
        ActiveCell.Offset(1, 0).Select
        Selection.PasteSpecial Paste:=xlPasteValuesAndNumberFormats, Operation:=xlNone, SkipBlanks _
             :=False, Transpose:=False
        Application.CutCopyMode = False
        currentWorkbook.Activate
        Set currentSheet = currentWorkbook.Sheets("Complete")
        currentSheet.Activate
        Set startCell = currentSheet.Range("A2")
        startCell.EntireRow.Select
        currentSheet.Range(Selection, Selection.End(xlDown).End(xlToRight)).Select
        Selection.Copy
        masterWB.Activate
        masterWB.Worksheets("Complete").Activate
        
        masterWB.Worksheets("Complete").Range("A2").Select
        Range(Selection, Selection.End(xlDown)).Select
        ActiveCell.Offset(1, 0).Select
        Selection.PasteSpecial Paste:=xlPasteValuesAndNumberFormats, Operation:=xlNone, SkipBlanks _
             :=False, Transpose:=False
        Application.CutCopyMode = False
        currentWorkbook.Close
        
        fileToOpen = Dir
    Loop
    
    
End Sub
[COLOR=#333333]

 

[baitmaster]

I've had a go at simplifying your code, this is untested so beware. The main point is to remove everything that's obsolete or not doing anything, so you can see the actual process more easily. I've left the old code as comments so you can see what relates to what - delete these comments and you'll how little you're left with

1 - stop selecting things. You are doing this in order to create a Selection object to work with, but you can work directly with any object without having to select it. I suggest this is an important lesson that will greatly improve the speed and efficiency of all of your code
2 - by working with the actual objects it seems you are always pasting to Range A3. I think you need to rethink how you create the range object at which you are pasting, and this is probably the fix to your problem

    Dim wsMaster As Worksheet: Set wsMaster = masterWB.Sheets("Master Schedule")    Dim wsMasterComplete As Worksheet: Set wsMaster = masterWB.Sheets("Complete")


    Do Until fileToOpen = vbNullString
        DoEvents
        
        ' create objects before processing
        Set currentWorkbook = Workbooks.Open(Path & fileToOpen)
        Set currentSheet = currentWorkbook.Sheets("Master Schedule")
        Set completeSheet = currentWorkbook.Sheets("Complete")          ' new object
        Set startCurrent = currentSheet.Range("A2")                     ' renamed object
        Set startComplete = completeSheet.Range("A2")                   ' renamed object
        
'        currentWorkbook.Activate
'        currentSheet.Activate
'        startCurrent.EntireRow.Select
'
'        currentSheet.Range(Selection, Selection.End(xlDown).End(xlToRight)).Select
'        Selection.Copy
        Range(startCurrent, startCurrent.End(xlDown).End(xlToRight)).Copy
        
'        masterWB.Activate
'        masterWB.Sheets("Master Schedule").Activate
'        masterWB.Sheets("Master Schedule").Range("A2").Select
'        Range(Selection, Selection.End(xlDown)).Select
'
'        ActiveCell.Offset(1, 0).Select
'        Selection.PasteSpecial Paste:=xlPasteValuesAndNumberFormats, Operation:=xlNone, SkipBlanks _
'             :=False, Transpose:=False
        
        wsMaster.Range("A2").Offset(1, 0).PasteSpecial Paste:=xlPasteValuesAndNumberFormats, Operation:=xlNone, SkipBlanks _
             :=False, Transpose:=False
        
'        Application.CutCopyMode = False
'        currentWorkbook.Activate
'        Set currentSheet = currentWorkbook.Sheets("Complete")
'        currentSheet.Activate
'        Set startCurrent = completeSheet.Range("A2")
'        startCurrent.EntireRow.Select
'        currentSheet.Range(Selection, Selection.End(xlDown).End(xlToRight)).Select
'        Selection.Copy
        
        Range(startComplete, startComplete.End(xlDown).End(xlToRight)).Copy
        
'        masterWB.Activate
'        masterWB.Worksheets("Complete").Activate
'        masterWB.Worksheets("Complete").Range("A2").Select
'
'        Range(Selection, Selection.End(xlDown)).Select
'        ActiveCell.Offset(1, 0).Select
'
'        Selection.PasteSpecial Paste:=xlPasteValuesAndNumberFormats, Operation:=xlNone, SkipBlanks _
'             :=False, Transpose:=False
        
        wsMasterComplete.Range("A2").Offset(1, 0).PasteSpecial Paste:=xlPasteValuesAndNumberFormats, Operation:=xlNone, SkipBlanks _
             :=False, Transpose:=False
        
        Application.CutCopyMode = False
        currentWorkbook.Close saveChanges:=False    ' tells Excel not to ask to save changes, doesn't save
        
        fileToOpen = Dir
        
    Loop

I think the fix may be, for example

        wsMaster.Range("A2").End(xlDown).Offset(1, 0).PasteSpecial Paste:=xlPasteValuesAndNumberFormats, Operation:=xlNone, SkipBlanks _
             :=False, Transpose:=False

 

[Doghouse308]

Thank you for your suggestion. I am not sure how much time I will have today to work with your ideas. I will let you know how this turns out when complete. Once I get the happy path working, then I'm going to add validation to make sure the files that are being opened contain the correct data and a few other tweaks to improve the UX.

 

[Doghouse308]

Thank you very much for your suggestion. This is much closer to what I need. There are just two minor issues remaining . I am not sure if this will make a difference or not. The source data is in a table and is being pasted into a table.

The two issues remaining are:

1) the first row the source data is being pasted into is row 4. The table headers are in row 2 and the set up macro that runs before the copy data clears the current data and resizes the table to include just two rows, the headers in row 2 and the first row of empty cells in row 3 which is where I would like the data import to begin.

2) the source data copied includes the header row. I need to start copying in the first row after the headers.

I really like your ideas and have modified them a little. The code below is what I am currently trying to use. (turning the screen updating off and back on are handled in setup and tear down subs)

Sub copyData_V2()
    
    Const sh_Master As String = "Master Schedule"
    Const sh_Complete As String = "Complete"
    Const sh_support As String = "Support"
    
    Dim path As String, fileToOpen As String
    Dim tabM, tabC, nmbrfrmtM, nmbrfrmtC
    Dim wbSource As Workbook
    Dim noPath As VbMsgBoxResult
    Dim noFiles As VbMsgBoxResult
    
    path = Trim(ThisWorkbook.Sheets(sh_support).Range("C6").Value)
    Do While path = ""
    path = Trim(ThisWorkbook.Sheets(sh_support).Range("C6").Value)
        MsgBox "Please Select Location of Individual Master Files"
        Call SelectPath
    Loop
    If Dir(path, vbDirectory) = "" Then
        noPath = MsgBox("Folder Does Not Exist.  Do you want to select a new folder?", vbYesNo, _
            "Folder Does Not Exist")
        If noPath = vbYes Then
            Call SelectPath
            path = Trim(ThisWorkbook.Sheets(sh_support).Range("C6").Value)
        Else
            MsgBox "No Valid Location for Individual Master Files", vbOKOnly, "Invalid Destination Folder"
            Exit Sub
        End If
    End If
    If Right(path, 1) <> "\" Then
        path = path & "\"
    End If
    
    fileToOpen = Dir(path & "*master*xls?", vbNormal)
    If fileToOpen = "" Then
        noFiles = MsgBox("No Mater Files Found. Select New Location?", vbYesNo, "No Mater Files Found")
        If noFiles = vbYes Then
            Call SelectPath
            path = Trim(ThisWorkbook.Sheets(sh_support).Range("C6").Value)
            fileToOpen = Dir(path & "*master*xls?", vbNormal)
        Else
            MsgBox "No Master Files Found", vbOKOnly, "No Master Files FOund"
            Exit Sub
        End If
    End If
        
    Do Until fileToOpen = ""
        If fileToOpen = ThisWorkbook.Name Then fileToOpen = Dir()
        
        Set wbSource = Workbooks.Open(path & fileToOpen, 0, False)
        With wbSource
            With .Sheets(sh_Master)
                With .Range("A2").CurrentRegion
                    tabM = .Value
                    nmbrfrmtM = .NumberFormat
                End With
            End With
            With .Sheets(sh_Complete)
                With .Range("A2").CurrentRegion
                    tabC = .Value
                    nmbrfrmtC = .NumberFormat
                End With
            End With
            
            .Close False
        End With
        Set wbSource = Nothing
        
        With ThisWorkbook
            With .Sheets(sh_Master)
                With .Range("A" & .Rows.Count).End(xlUp).Offset(1, 0).Resize(UBound(tabM, 1), UBound(tabM, 2))
                    .Value = tabM
                    .NumberFormat = nmbrfrmtM
                End With
            End With
            With .Sheets(sh_Complete)
                With .Range("A" & .Rows.Count).End(xlUp).Offset(1, 0).Resize(UBound(tabC, 1), UBound(tabC, 2))
                    .Value = tabC
                    .NumberFormat = nmbrfrmtC
                End With
            End With
        End With
        
        tabM = Empty:  tabC = Empty
        nmbrfrmtM = Empty:  nmbrfrmtC = Empty
        
        fileToOpen = Dir()
        DoEvents
    Loop
    
    MsgBox "Update Complete"
End Sub

 

[baitmaster]

Point 2 is probably an easy fix, simply resize the range you're working with to chop off row 1:

            With .Sheets(sh_Master)
                With .Range("A2").CurrentRegion
                    With .Offset(1, 0).Resize(.Rows.Count - 1, .Columns.Count)
                        tabM = .Value
                        nmbrfrmtM = .NumberFormat
                    End With
                End With
            End With

As for point 1, I can't see why it's creating a blank row, unless your set-up routine is entering null values "" into the cells. This is not the same as an empty cell, and so your .end(xlUp) manoeuvre is jumping to the null value instead of the text row above it. If this always happens then you could drop the Offset(1,0), but I'd prefer to not import the Null values in the first place, or at least test for them before deciding whether to .Offset or not

I note you're always using .Range("A2") and never .Cells(2, 1) which is the same thing in a different notation. Personally I prefer .Cells as I find it more flexible since you can easily add numbers in both rows & columns. Just as an idea which may or may not be useful in this code, I've used the following function in just about every piece of code I've written in the last 15 years, this can be easily adapted to work with columns or individual ranges instead

Function lastUsedRow(ws As Worksheet) As Long

On Error Resume Next
    lastUsedRow = ws.Cells.Find("*", Range("A1"), xlFormulas, , xlByRows, xlPrevious).Row
On Error GoTo 0

End Function

And as for the screenupdating, again I hardly ever use it. Maybe in this case as you're opening & closing files, but usually it's used to hide Selecting of ranges which is bad practice anyway. Interactions between Excel and VBA are what slows your code down, and by minimising these - i.e. processing everything within VBA, and storing results in Arrays / dictionaries then pasting results once, rather than pasting multiple times - then your code will run slicker and generally not need messing with screenupdating, which itself can get in the way when debugging. Plus I like a little bit of action on screen so I know my code hasn't frozen or gone into a terminal loop...

 

[Doghouse308]

Thank you for your suggestions and I apologize for the delayed reply.

I found a similar solution to problem 2 and felt foolish for not doing my due diligence before posting my reply. After reading your signature I did a quick search and found the solution quickly.

I REALLY like your last row function and will work with that this weekend.

Regretfully, while there is a sense of urgency to get this tool completed, I am not given more than 4-6 hours during the work week to devote to this.

When this is complete I will post my code for comments and suggestions. Your help is greatly appreciated.