Problem with combining workbooks.

[jaynorman46]

Hi,
Im new to this forum and am sorry if this question has been asked already..

I have code that combines multiple workbooks into a single sheet, However the problem is the order that they are combined. All of these files are in a single folder and there is no other type of file in the folder, also all files are .xlsm and not .xlsx. I have renamed all of them using the alt+255 function so that all of the of the files are

(1).xlsm
(2).xlsm
(3).xlsm
etc... all the way to (339).xlsm

The problem,

the code imports in this order

(1).xlsm
(10).xlsm
(100).xlsm
(101).xlsm
etc....

and I need it in 1,2,3,4 order

Is there anything I can do about this? I have tried multiple different types of Loops and posted codes for this and they all do the same order..

Here is the code(based off of schielrn (Board Regular) code post Jan 18th, 2008, 12:05 PM):


Sub MergeFiles()
Dim path As String, ThisWB As String, lngFilecounter As Long
Dim wbDest As Workbook, shtDest As Worksheet, ws As Worksheet
Dim Filename As String, Wkb As Workbook
Dim CopyRng As Range, Dest As Range

ThisWB = ActiveWorkbook.Name

Set wbDest = ActiveWorkbook




path = ("C:\Documents and Settings\JNorma1\My Documents\Happy Jack Daily site reports 2010")
Application.EnableEvents = False
Application.ScreenUpdating = False
Set shtDest = ActiveWorkbook.Sheets("Upload File")
Filename = Dir(path & "\*.xls", vbNormal)

If Len(Filename) = 0 Then Exit Sub
Do Until Filename = vbNullString
If Not Filename = ThisWB Then
Set Wkb = Workbooks.Open(Filename:=path & "\" & Filename)
Set CopyRng = Wkb.Sheets(1).Range("G31:N45")
Set Dest = shtDest.Range("A" & shtDest.UsedRange.SpecialCells(xlCellTypeLastCell).Row + 1)
CopyRng.Copy
wbDest.Activate

Sheets("Upload File").Select
Dest.PasteSpecial xlPasteValuesAndNumberFormats
Application.CutCopyMode = False 'Clear Clipboard
Wkb.Close True


End If

Filename = Dir()
Loop


Range("A1").Select

Application.EnableEvents = True
Application.ScreenUpdating = True

MsgBox "Done!"

End Sub

 

[Joe4]

Welcome to the Board!

They are sorting this way because since your numbers are being combined with text, they are being treated as text. If you want them to sort in the correct order, try changing your naming convention so that they are all the same length.

So, instead of using
1
2
3
...
339

try using:
001
002
003
...
339

Then they should sort in the order you like.

 

[jaynorman46]

Joe4 thanks for your Response!

Is there any way of quickly doing this without renaming all 339 workbooks individually?

 

[Joe4]

I have not run or tried to completely analyzed your macro. What are you looking to rename at this point, sheet names or row of data?
What does the full entry look like (not just the ending)?

 

[jaynorman46]

I would have to go and rename all 339 workbooks individually with the respective 001,002,003 all the way to 339. the full name is at this point exactly examples I gave earlier,

(1).xlsm
(2).xlsm
etc...

I originally had them named in order of date such as

HPJ Daily Report 2010 1-1.xlsm
HPJ Daily Report 2010 1-2.xlsm
HPJ Daily Report 2010 1-3.xlsm

all the way until

HPJ Daily Report 2010 12-31.xlsm

But I thought the date was reason I was having the problem so I selected all and renamed all of them using the alt+255 function so that they became the respective

(1).xlsm
(2).xlsm

 

[Joe4]

Well, I would approach this a little differently. You could use VBA code to first loop through all the files in your folder and rename the files with current date formats, i.e.

Change: "HPJ Daily Report 2010 1-1.xlsm"
to: "HPJ Daily Report 2010-01-01.xlsm"

With a two digit month and year, all the files should now sort chronolgically in date order.

Here is a rather crude, but effective UDF that will convert the file name for you (I have not added any error trapping or anything like that). You should be able to incorporate this in a loop to rename your file names before you combine them.

Function RenameDate(myFileName As String) As String
    Dim myDate As String
    
'   Pull out date portion (date starts in space 18, and extension is 4 characters)
    myDate = Mid(myFileName, 18, Len(myFileName) - 18 - 4)
    
'   Replace spaces with dash
    myDate = Replace(myDate, " ", "-")
    
'   Insert 0 in month, if missing
    If Mid(myDate, 7, 1) = "-" Then
        myDate = Left(myDate, 5) & "0" & Right(myDate, Len(myDate) - 5)
    End If
    
'   Insert 0 in day, if missing
    If Len(myDate) = 9 Then
        myDate = Left(myDate, 8) & "0" & Right(myDate, 1)
    End If
    
    RenameDate = Left(myFileName, 17) & myDate & ".xlsm"
    
End Function

 

[Joe4]

In case you need code to use that UDF to rename those files, here is what that code would look like:

Sub MyRenameFiles()
 
    Dim MyFolder As String
    Dim MyFile As String
    
'   Enter your folder name here
    MyFolder = "C:\Documents and Settings\JNorma1\My Documents\Happy Jack Daily site reports 2010\"
    
'   Loop through all xlsm files and rename
    MyFile = Dir(MyFolder & "*.xlsm")
    Do While Len(MyFile) > 0
        Name MyFile As RenameDate(MyFile)
        MyFile = Dir
    Loop
    
    MsgBox "Files renamed!"
    
End Sub

 

[jaynorman46]

Thanks so much for all of your Help!!

but im getting a "file not found' error at

Do While Len(MyFile) > 0
Name MyFile As RenameDate(MyFile)
MyFile = Dir
Loop

I looked into it a little and the function does everything correctly, am i not naming something right?

total code:


Sub MyRenameFiles()

Dim MyFolder As String
Dim MyFile As String

' Enter your folder name here
MyFolder = "C:\Documents and Settings\JNorma1\My Documents\Happy Jack Daily site reports 2010\"

' Loop through all xlsm files and rename
MyFile = Dir(MyFolder & "*.xlsm")
Do While Len(MyFile) > 0
Name MyFile As RenameDate(MyFile)
MyFile = Dir
Loop

MsgBox "Files renamed!"

End Sub

---------------------------------------------------------------

Function RenameDate(myFileName As String) As String
Dim myDate As String

Dim ed As String

ed = ".xlsm"

' Pull out date portion (date starts in space 18, and extension is 4 characters)
myDate = Mid(myFileName, 18, Len(myFileName) - 18 - 4)

' Replace spaces with dash
myDate = Replace(myDate, " ", "-")

' Insert 0 in month, if missing
If Mid(myDate, 7, 1) = "-" Then
myDate = Left(myDate, 5) & "0" & Right(myDate, Len(myDate) - 5)
End If

' Insert 0 in day, if missing
If Len(myDate) = 9 Then
myDate = Left(myDate, 8) & "0" & Right(myDate, 1)
End If

RenameDate = Left(myFileName, 17) & myDate & ed


End Function

 

[Joe4]

Insert the line:
MsgBox MyFile
before the line you have highlighted in red, and let us know what it returns.

 

[jaynorman46]

HPJ Daily Report 2010 01-25.xlsm

This is actually the first file in the folder as There is no previous files before January 25th 2010