Assistance with an Upload Macro

[ollieotis]

Hello,

I'm attempting to write a macro that will allow me to upload multiple workbooks into a single workbook, and save as a new file. I have approximately 450 workbooks with alphanumeric names, each with only one worksheet per. Each alphanumeric name has three distinct files.

For example, the file names would be:

AAA01023 E.xls
AAA01023 P.xls
AAA01023 F.xls
BBB01023 E.xls
BBB01023 P.xls
BBB01023 F.xls
ZZZ01023 E.xls
ZZZ01023 P.xls
ZZZ01023 F.xls

What I would like to end up with is a new file with approximately 150 workbooks, each with 3 seperate tabs (E, F, P). Each file name would correspond to the unique alphanumeric project code, i.e. ZZZ01023.

I have a little experience with VBA, but am struggling with how to start this one. Any help would be greatly appreciated.

Thanks!

 

[ktab]

This is not tested but give it a try:

Option Explicit

Sub test_Sub()
Dim wsCollection As New Collection, fs As FileSearch
Dim MyPath As String, x, z, i As Long, r As Long, m As Long, cCount As Long, strS As String
Dim fStr As String, SavePath As String
Dim New_WB As Workbook, Origin_WB As Workbook, ws As Worksheet

Set fs = Application.FileSearch
MyPath = "d:\" 'your workbook collection path here
SavePath = "d:\test" 'the path that you need to store new books here take care to create folder or code will hang
fStr = ""

With fs
    .SearchSubFolders = False
    .FileType = msoFileTypeExcelWorkbooks
    .LookIn = MyPath
    If .Execute > 0 Then
        For i = 1 To .FoundFiles.Count
            x = Split(.FoundFiles(i), " ")
            fStr = CStr(x(0))
            On Error Resume Next
            wsCollection.Add fStr, fStr
            If Err.Number = 0 Then
                Set New_WB = Workbooks.Add
                For r = 1 To .FoundFiles.Count
                    If .FoundFiles(r) Like fStr & " *" Then
                        x = Split(.FoundFiles(r), " ")
                        Set ws = New_WB.Sheets(r)
                        Set Origin_WB = Workbooks.Open(.FoundFiles(r))
                        Origin_WB.ActiveSheet.Cells.Copy ws.[a1]
                        Origin_WB.Close
                        z = Split(x(1), ".")
                        ws.Name = CStr(z(0))
                    End If
                Next r
                cCount = 0
                strS = ""
                For m = Len(fStr) To 1 Step -1
                    strS = Mid(fStr, m, 1)
                    If strS = "\" Then Exit For
                    cCount = cCount + 1
                Next m
                fStr = Mid(fStr, Len(fStr) - cCount + 1)
                New_WB.SaveAs SavePath & "\" & fStr & ".xls"
                New_WB.Close
                Set New_WB = Nothing
                fStr = ""
            End If
            Err.Clear
        Next i
    End If
End With

End Sub

 

[ollieotis]

Thank you for your assitance, Kostas. Unfortunately, I can not get this code to work, and after an hour plus of trying to read through it to see what needs to be modified (that's how we learn, right), I'm still struggling with it.

Right now, when I run the macro, I get one of two results. If I create a new subfolder (save path) within the file that contains all the workbooks, I get prompted to save each new workbook under the proper name, but those files are blank when I open them. If I create a new folder somewhere else on my drive, the macro results in a new excel workbook being opened, but nothing saved.

I know this is really close, but I'm still not getting it. Any further help would be greatly appreciated.

Thanks!

 

[ktab]

tell me exactly what are your 2 strings (what's in the "...."):
mypath & savepath

 

[ollieotis]

Hi Kostas,

I have the following for my 2 strings:

Set fs = Application.FileSearch
MyPath = "H:\SRC"
SavePath = "H:\Budgets"
fStr = ""

Thanks again for your help!

 

[ktab]

OK now I tested before posting. To me it worked; to you? :

Option Explicit


Sub test_Sub()
Dim wsCollection As New Collection, fs As FileSearch
Dim MyPath As String, x, z, i As Long, r As Long, m As Long, cCount As Long, strS As String
Dim fStr As String, SavePath As String, WB_created As Boolean, WS_count As Long
Dim New_WB As Workbook, Origin_WB As Workbook, ws As Worksheet

Set fs = Application.FileSearch
MyPath = "H:\SRC"
SavePath = "H:\Budgets"
fStr = ""

Application.ScreenUpdating = False

With fs
    .SearchSubFolders = False
    .FileType = msoFileTypeExcelWorkbooks
    .LookIn = MyPath
    If .Execute > 0 Then
        For i = 1 To .FoundFiles.Count
            x = Split(.FoundFiles(i), " ")
            fStr = CStr(x(0))
            On Error Resume Next
            wsCollection.Add fStr, fStr
            If Err.Number = 0 Then
                WB_created = False
                For r = 1 To .FoundFiles.Count
                    If .FoundFiles(r) Like fStr & " *" Then
                        Set Origin_WB = Workbooks.Open(.FoundFiles(r))
                        If Not WB_created Then
                            Origin_WB.ActiveSheet.Copy
                            Set New_WB = ActiveWorkbook
                            Set ws = New_WB.ActiveSheet
                            WB_created = True
                        Else
                            WS_count = New_WB.Sheets.Count
                            Origin_WB.ActiveSheet.Copy After:=New_WB.Sheets(WS_count)
                            Set ws = New_WB.ActiveSheet
                        End If
                        Origin_WB.Close
                        x = Split(.FoundFiles(r), " ")
                        z = Split(x(1), ".")
                        ws.Name = CStr(z(0))
                    End If
                Next r
                cCount = 0
                strS = ""
                For m = Len(fStr) To 1 Step -1
                    strS = Mid(fStr, m, 1)
                    If strS = "\" Then Exit For
                    cCount = cCount + 1
                Next m
                fStr = Right(fStr, cCount)
                Application.DisplayAlerts = False
                New_WB.SaveAs SavePath & "\" & fStr & ".xls"
                Application.DisplayAlerts = True
                New_WB.Close
                Set New_WB = Nothing
                fStr = ""
            End If
            Err.Clear
        Next i
    End If
End With

Application.ScreenUpdating = True

End Sub

 

[ollieotis]

Works perfectly. Thank you so much for your help, Kostas!