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

A

andocommanndo

New Member
Joined
Oct 26, 2014
Messages
11
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...
Rich (BB code): 
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
 

Excel Facts

Create a chart in one keystroke
Select the data and press Alt+F1 to insert a default chart. You can change the default chart to any chart type
Sort by date Sort by votes
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
 
Upvote 0
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.
 
Last edited:
Upvote 0
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
Rich (BB code): 
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!!
 
Upvote 0
It seems easier to fix the code in your first post rather than trying to understand your subsequent replies.

andocommanndo said:
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"
Click to expand...
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.
Click to expand...
Not fixed this.

And, I would also like a space between each set of data to separate individual file information.
Click to expand...
Add 1 to NR?

Here's your code with the above changes:

Code: 
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
 
Upvote 0
John, thanks for taking the time to look at this, the code stops working at the spot noted below.
Code: 
            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]
 
Upvote 0
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.
 
Upvote 0
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!!!
Code: 
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
 
Last edited:
Upvote 0
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 ....

Code: 
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?
 
Upvote 0
You must log in or register to reply here.

Similar threads

B
  • Question
VBA to extract data from multiple folders and add to a master workbook plus identifying tags
Replies
2
Views
898
John_w
J
2
  • Question
Selecting all files from folder by week number
Replies
0
Views
615
22gree
2
A
  • Question
Automation of Copy and Merge Data in Column A and B of all files in a folder. Order of Data Differs
Replies
2
Views
511
ashish002
A
A
  • Question
VBA Run-time error '52' : Bad file name or number - save file on Sharepoint
Replies
7
Views
6K
alantse2010
A
D
  • Question
Merge Workbooks from Multiple Folders Based on by reading Order Numbers in Excel file
Replies
1
Views
496
ExcelToDAX
E

Forum statistics

Threads
1,216,076
Messages
6,128,670
Members
449,463
Latest member
Jojomen56

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top