Need Help Compiling Data From Multiple excel Files in order of filename

[andocommanndo]

I have gotten code from other threads and for the most part it works great.
It is copying data from all excel files in a certain folder, then pasting them into one sheet.
The issue I am having is when it is copying data to new sheet, it is not in order of file name.
file name is in date format "YYYYMMDD HHMM"
I also don't know enough about the code to change my column "A" from coming back with "0" since the source files have no data there.
And, I would also like a space between each set of data to separate individual file information.
Here is what I have...

Option Explicit

Private Sub Workbook_Open()
MsgBox "This will compile all the operator rounds in the NH3 Daily Folder. Enjoy!" & vbNewLine & "Make Sure Your Macros Are Enabled."
Dim fPATH As String, fNAME As String
Dim LR As Long, NR As Long
Dim wbGRP As Workbook, wsDEST As Worksheet
Set wsDEST = ThisWorkbook.Sheets("Summary")
NR = wsDEST.Range("B" & Rows.Count).End(xlUp).Row + 1
fPATH = "\\smrt01-dc01-pr\Operator_Required_Rounds\NH3Daily\"       'remember the final \ in this string
fNAME = Dir(fPATH & "*.xls")        'get the first filename in fpath
Do While Len(fNAME) > 0
    Set wbGRP = Workbooks.Open(fPATH & fNAME)   'open the file
    LR = wbGRP.Sheets("Ammonia Skid (Daily)").Range("B" & Rows.Count).End(xlUp).Row  'how many rows of info?
    
    If LR > 3 Then
        wsDEST.Range("A" & NR) = Replace(Range("A1"), "Group ", "")
        wbGRP.Sheets("Ammonia Skid (Daily)").Range("B3:F" & LR).Copy
        wsDEST.Range("B" & NR).PasteSpecial xlPasteAll
        NR = wsDEST.Range("B" & Rows.Count).End(xlUp).Row + 1
    End If
    
    wbGRP.Close False   'close data workbook
        fNAME = Dir         'get the next filename
Loop
Range("A3:A" & NR - 1).SpecialCells(xlBlanks).FormulaR1C1 = "=R[-1]C"
With Range("A3:A" & NR - 1)
    .Value = .Value
End With
End Sub

any help would be much appreciated

 

[thunder_anger]

Had same prblem befor e
Google RDB Merge addin
it is great

 

[andocommanndo]

This is being put into place for other users with minimal computer abilities. Everything runs on startup so they can't not get it right. But, right now, I can't get it right.

I have no idea why the files are being copied randomly. It starts off correctly but then soon gets off track

 

[andocommanndo]

I am ready to throw the whole thing out and start over.....
instead of the current code written, would there be a way to change it so it doesn't copy all the data off the sheet? Ideally it would workbest if; (please excuse the format)
Orginal Sheet New Sheet (in new file)
C2 ----------->B4
C3 ----------->C4
D4 ----------->D4
D5 ----------->E4
D6 ----------->F4
D7 ----------->G4
D8 ----------->H4.......all way to
D12 ---------->L4

Then the next file will collect the same cells from Original Sheet, then insert on New Sheet it one row down. At the end I can do a sort function to fix any out of place data.

 

[andocommanndo]

Been working all day on this.
I am taking a different approach, and I could really use some assistance. The things I've seen done on these forums is amazing, so I really want there to be a way to fix my problem

Private Sub Workbook_Open()

Dim fNAME As String
Dim fPATH As String
Dim flag As Boolean
Dim i As Integer

fPATH = "\\smrt01-dc01-pr\Operator_Required_Rounds\NH3Daily\"
i = 1
flag = True
fNAME = Dir(fPATH & "*.xls")
While flag = True
    If fNAME = "" Then
        flag = False
    Else
        Cells(i + 1, 1) = fNAME
        Cells(i + 1, 2) = fPATH
        Cells(i + 1, 3) = "$C$2" 'copy to new sheet cell B4
        Cells(i + 1, 4) = "$C$3" 'copy to new sheet cell C4
        Cells(i + 1, 5) = "$D$4" 'copy to new sheet cell D4
        Cells(i + 1, 6) = "$D$5" 'copy to new sheet cell E4
        Cells(i + 1, 7) = "$D$6" 'copy to new sheet cell F4
        Cells(i + 1, 8) = "$D$7" 'copy to new sheet cell G4
        Cells(i + 1, 9) = "$D$8" 'copy to new sheet cell H4
        Cells(i + 1, 10) = "$D$9" 'copy to new sheet cell I4
        Cells(i + 1, 11) = "$D$10" 'copy to new sheet cell J4
        Cells(i + 1, 12) = "$D$11" 'copy to new sheet cell K4
        Cells(i + 1, 13) = "$D$12" 'copy to new sheet cell L4
        Cells(i + 1, 14) = "NH3 Daily Report" 'name of sheet in current workbook to copy to
        Cells(i + 1, 15) = "$B$4" 'starting cell for "NH3 Daily Report" sheet
        'returns the next file or directory in the path
        fNAME = Dir
        i = i + 1
    End If
Wend
End Sub

So, I thought I would take an easier approach. But, I run into walls everywhere I try to go from here. I need to sort the rows compiled, by my filename(column A, starting at cell A2) on the active sheet (called "List"). Then use this "List" sheet to point to the information I need to pull into my new sheet ("NH3 Daily Report") In the same workbook. Then Ideally hide sheet "List".
I think it is more what I need than the previous code. But, I am stuck. Please Help!!

 

[John_w]

It seems easier to fix the code in your first post rather than trying to understand your subsequent replies.

The issue I am having is when it is copying data to new sheet, it is not in order of file name.
file name is in date format "YYYYMMDD HHMM"

Put the file names in an array, sort the array and loop through the array to open each source workbook.

I also don't know enough about the code to change my column "A" from coming back with "0" since the source files have no data there.

Not fixed this.

And, I would also like a space between each set of data to separate individual file information.

Add 1 to NR?

Here's your code with the above changes:

Option Explicit

Private Sub Workbook_Open()

    Dim fPATH As String, fNAME As String
    Dim LR As Long, NR As Long
    Dim wbGRP As Workbook, wsDEST As Worksheet
    Dim fileNames() As String, i As Long
    
    MsgBox "This will compile all the operator rounds in the NH3 Daily Folder. Enjoy!" & vbNewLine & "Make Sure Your Macros Are Enabled."
    
    Set wsDEST = ThisWorkbook.Sheets("Summary")
    NR = wsDEST.Range("B" & Rows.Count).End(xlUp).Row + 1
    fPATH = "\\smrt01-dc01-pr\Operator_Required_Rounds\NH3Daily\"       'remember the final \ in this string
    
    fNAME = Dir(fPATH & "*.xls")        'get the first filename in fpath
    i = 0
    Do While fNAME <> ""
        ReDim Preserve fileNames(i)
        fileNames(i) = fNAME
        i = i + 1
        fNAME = Dir
    Loop
    
    BubbleSort fileNames
    
    For i = 0 To UBound(fileNames)
        Set wbGRP = Workbooks.Open(fPATH & fileNames(i))   'open the file
        LR = wbGRP.Sheets("Ammonia Skid (Daily)").Range("B" & Rows.Count).End(xlUp).Row  'how many rows of info?
        
        If LR > 3 Then
            wsDEST.Range("A" & NR) = Replace(Range("A1"), "Group ", "")
            wbGRP.Sheets("Ammonia Skid (Daily)").Range("B3:F" & LR).Copy
            wsDEST.Range("B" & NR).PasteSpecial xlPasteAll
            NR = wsDEST.Range("B" & Rows.Count).End(xlUp).Row + 2
        End If
        
        wbGRP.Close False   'close data workbook
    Next
    
    Range("A3:A" & NR - 1).SpecialCells(xlBlanks).FormulaR1C1 = "=R[-1]C"
    With Range("A3:A" & NR - 1)
        .Value = .Value
    End With
    
End Sub


Private Sub BubbleSort(data() As String)

    'Sort a one-dimensional string array
    
    Dim i As Long, j As Long
    Dim temp As String
    
    For i = LBound(data) To UBound(data) - 1
        For j = i + 1 To UBound(data)
            If data(i) > data(j) Then                'ascending order
            'If data(i) < data(j) Then                'descending order
                temp = data(i)
                data(i) = data(j)
                data(j) = temp
            End If
        Next
    Next
     
End Sub

 

[andocommanndo]

John, thanks for taking the time to look at this, the code stops working at the spot noted below.

            wsDEST.Range("A" & NR) = Replace(Range("A1"), "Group ", "")
            wbGRP.Sheets("Ammonia Skid (Daily)").Range("B3:F" & LR).Copy
            wsDEST.Range("B" & NR).PasteSpecial xlPasteAll
            NR = wsDEST.Range("B" & Rows.Count).End(xlUp).Row + 2
        End If
        
        wbGRP.Close False   'close data workbook
    Next
    
    Range("A3:A" & NR - 1).SpecialCells(xlBlanks).FormulaR1C1 = "=R[-1]C"
    With Range("A3:A" & NR - 1)
        .Value = .Value
    End With
    
End Sub


Private Sub BubbleSort(data() As String)

    'Sort a one-dimensional string array
    
    Dim i As Long, j As Long
    Dim temp As String
    
    For i = LBound(data) To UBound(data) - 1
        For j = i + 1 To UBound(data)
            If data(i) > data(j) Then                'ascending order
            'If data(i) < data(j) Then                'descending order
                temp = data(i)
                data(i) = data(j)
                data(j) = temp
            End If
        Next
    Next
     
End Sub

[/QUOTE]

 

[John_w]

I can't tell which line it stops working at from your last post. And what do you mean by 'stops working'? Any error messages? Try stepping through the code line by line in the VBA editor by pressing the F8 key and see if the variables and merging results are what you expect.

Apart from the adding 1 to NR (the + 2 part of the code), I haven't changed the data merging part of the code, and I can't really help with that without knowing more about the layout of the source data.

 

[andocommanndo]

I don't know really what was wrong, but I went through and added the parts you changed one by one instead of copying the whole code, then went through error by error changing things to get me to a point it would run. Finally, I changed the BubbleSort code, and it seems to be working now.
Your idea was amazing, something I didn't know was possible, thanks for your time and code. Below, is the seemingly working code, feel free to comment on how I can make it better (or where I muddled it up). And, thank you again!!!

Option Explicit
Private Sub Workbook_Open()

ActiveSheet.Unprotect Password:="Operator"

MsgBox "This will compile all the operator rounds in the NH3 Daily Folder. Enjoy!" & vbNewLine & "Make Sure Your Macros Are Enabled."

Dim fPATH As String, fNAME As String
Dim LR As Long, NR As Long
Dim wbGRP As Workbook, wsDEST As Worksheet
Dim fileNames() As String, i As Long


Set wsDEST = ThisWorkbook.Sheets("Summary")
NR = wsDEST.Range("B" & Rows.Count).End(xlUp).Row + 1

fPATH = "\\smrt01-dc01-pr\Operator_Required_Rounds\NH3Daily\"       'remember the final \ in this string

fNAME = Dir(fPATH & "*.xls")        'get the first filename in fpath
i = 0
Do While Len(fNAME) > 0
        ReDim Preserve fileNames(i)
        fileNames(i) = fNAME
        i = i + 1
        fNAME = Dir
    Loop
    
    BubbleSort fileNames
    For i = 0 To UBound(fileNames)
        Set wbGRP = Workbooks.Open(fPATH & fileNames(i))   'open the file
        LR = wbGRP.Sheets("Ammonia Skid (Daily)").Range("B" & Rows.Count).End(xlUp).Row  'how many rows of info?
    If LR > 3 Then
        wsDEST.Range("A" & NR) = Replace(Range("A1"), "Group ", "")
        wbGRP.Sheets("Ammonia Skid (Daily)").Range("B3:F" & LR).Copy
        wsDEST.Range("B" & NR).PasteSpecial xlPasteAll
        NR = wsDEST.Range("B" & Rows.Count).End(xlUp).Row + 1
    End If
    
    wbGRP.Close False   'close data workbook
Next

Range("A3:A" & NR - 1).SpecialCells(xlBlanks).FormulaR1C1 = "=R[-1]C"
With Range("A3:A" & NR - 1)
    .Value = .Value
End With

End Sub


Sub BubbleSort(list() As String)
'   Sorts an array using bubble sort algorithm
    Dim First As Integer, Last As Long
    Dim i As Long, j As Long
    Dim Temp
    
    First = LBound(list)
    Last = UBound(list)
    For i = First To Last - 1
        For j = i + 1 To Last
            If list(i) > list(j) Then
                 Temp = list(j)
                list(j) = list(i)
                list(i) = Temp
            End If
        Next j
    Next i
End Sub

 

[andocommanndo]

Ok, so now that this works..... I have a number for folders I would like to apply this to. the files are almost the same, the difference being, sheet name and range of cells to copy. I tried to apply this to the next folder with the changes I just mentioned and I get "Run Time Error '9': Subscript out of Range" on ....

Sub BubbleSort(list() As String)
'   Sorts an array using bubble sort algorithm
    Dim First As Integer, Last As Long
    Dim i As Long, j As Long
    Dim Temp
    
    First = LBound(list) 'This is the line that is highlighted in debugger
    Last = UBound(list)
    For i = First To Last - 1
        For j = i + 1 To Last
            If list(i) > list(j) Then
                 Temp = list(j)
                list(j) = list(i)
                list(i) = Temp
            End If
        Next j
    Next i
End Sub

Sorry for dragging this out....Any thoughts on what it is I'm missing?