Import Multi Workbooks to seperate tabs

[fiftimedun]

New to VBA and this is over my head, any assistance would be greatly appreciated:

I have multiple workbooks that i need imported into a single workbook but each workbook must go on to its own tab. I would like the operation to give you the option to search for the folder that contains all of the workbooks (they will be in the same folder, but the folder will change)

Notes:
-Workbooks have a date at the end so the end must be wildcard
-Workbooks must be able to be assigned to copy their data to a tab that has a different name than the origin workbook, eg. workbook "Red", imports to tab "Seven"
--i can manually name and assign the workbook/tab names or provide a sample of what i am working with (there are 21 reports to import, each to seperate tabs)

Here is what i have to search for the folder, but i don't really understand how it works or what to do with it...

Sub test()
    
    MsgBox "Please navigate to the folder containing the files to process."
    
    With Application.FileDialog(msoFileDialogFolderPicker)
    .Show
        On Error Resume Next
        fileLocation = .SelectedItems(1)
    End With
   
    If fileLocation = "" Then
        End
    End If
    
End Sub

Thank you all in advance for your time!

 

[fiftimedun]

Thank you very much for responding to my thread, I have onelast bump and then I should be in the clear. If you could respond to me onelast time with a (I am sure an easy fix for an expert like yourself) bit ofcode help, I would very much appreciate it. I am in the military (if you can'ttell from the thread reports) and I am just very tired of the weak tracking wehave on our training. In an effort to streamline and reduce errors I am makingan all in one tracker for our online required training.

Thank you again

~Fiftimedun

I apologize for posting pertinent info on another thread,but like I said in that one, I was trying to re-attack this in a differentmanner. Now that I have the copy you gave me I am trying to adapt it, but usingthe first if

Sub Import_1st_Sheet_From_All_Workbooks_In_Folder()
     Dim folder AsString, fileName As String
     Dim thisWb AsWorkbook
     Dim i As Integer
     
    Set thisWb =ActiveWorkbook
     
    folder =""
     WithApplication.FileDialog(msoFileDialogFolderPicker)
         If .Show = -1Then folder = .SelectedItems(1)
     End With
     
    If folder<> "" Then
         i = 0
         fileName =Dir(folder & "\*.xls")
         WhilefileName <> ""
             i = i + 1
            Workbooks.Open folder & "\" & fileName
              IffileName Like "354_LRS-_DoD_Information_Assurance_Awareness*" Then
             Sheets(1).Copy thisWb.Sheets("DoD IA Report")
              End If
           ' WithActiveWorkbook
            '     .Sheets(1).CopyAfter:=thisWb.Sheets(thisWb.Sheets.Count)
            '     .Close savechanges:=False
            '     thisWb.Sheets(thisWb.Sheets.Count).Name =thisWb.Sheets(thisWb.Sheets.Count).Name & " " &thisWb.Sheets.Count
            ' End With
            ' fileName= Dir
         Wend
     End If
     
End Sub

I commented out your part of the code for my own... didn'twork

I tried setting it up for one report to try it out and thissent excel into an endless loop of opening the same report over and over again,and not the in in the code even...
Side note: After the holiday season my next college courseis going to involve VBA, I can't wait to be the one answer these questions...

 

[John_w]

See this is where i hate to say it, but i'll have to do an individual adding of a bunch of "if....like..then..end if" statements because here is an example of the naming system on the sheet:

Filename: 354_LRS-Air_Force_2A_Culture_General_Course_(ZZ133104)-Users-12-28-2012.xls
Tab: Culture Gen Report

You haven't answered my questions. Providing one example is not enough for me to see whether there is a system or rule for naming the imported sheet after the name of the workbook from which it is imported. Please post the examples in your other thread that I asked you to post in this thread.

Also, your version of my code doesn't compile because of missing spaces.

 

[fiftimedun]

-354_LRS-Biometrics_Awareness_Course_(ZZ133117)-Users-12-19-2012.xls
--Goes to Biometrics Report

-354_LRS-CBRN_Defense_Awareness_Course_v1.0_(ZZ133039),_Dec_2009-Users-12-19-2012.xls
--Goes to CBRNE v1.0 CBT Report

-354_LRS-CBRN_Defense_Survival_Skills_Completion_(Hands-On)-Users-12-19-2012.xls
--Goes to CBRNE Hands-on Report

-354_LRS-Collect_and_Report_Information_(20091007)_(ZZ133102)-Users-12-19-2012.xls
--Goes to Collect and Report Info Report

-354_LRS-Communication_Engagement_Training_for_Deploying_Warfighters_(20091007)_(ZZ133099)-Users-12-19-2012.xls
--Goes to Comm Engagement Train Report

354_LRS-Don't_Ask,_Don't_Tell_Repeal_Training_--_Tier_3-Users-12-19-2012.xls
--Goes to DADT Report

-354_LRS-Equal_Opportunity_and_Prevention_of_Sexual_Harassment_Deployment_Briefing_(20091007)_(ZZ133101)-Users-12-19-2012.xls
--Goes to EO & Prevent Sex Harass Report

354_LRS-Explosive_Ordnance_Reconnaissance_(EOR)_Course_v2.0_(ZZ133107),_Dec_09-Users-12-19-2012.xls
--Goes to EOR V2.0 Report

-354_LRS-Law_of_Armed_Conflict_(LOAC)_–_2011-Users-12-19-2012.xls
--Goes to LOAC 2011 Report

-354_LRS-Professional_and_Unprofessional_Relationships_(20091007)_(ZZ133103)-Users-12-19-2012.xls
--Goes to Pro Unpro Report

-354_LRS-Self-Aid_and_Buddy_Care_(ZZ131008)-Users-12-19-2012.xls
--Goes to SABC CBT Report

-354_LRS-Self-aid_Buddy_Care_(Hands-On)-Users-12-19-2012.xls
--Goes to SABC Hands On Report

-354_LRS-SERE_100.1-Users-12-19-2012.xls
--Goes to SERE 100.1 Report

-354_LRS-_DoD_Information_Assurance_Awareness_(ZZ133098)_v10-Users-12-19-2012.xls
--Goes to DoD IA Report

-354_LRS-_Force_Protection_(ZZ133079)-Users-12-19-2012.xls
--Goes to Force Protection Report

-354_LRS-_Human_Relations_(ZZ133080)-Users-12-19-2012.xls
--Goes to Human Relations Report

-354_LRS-_Information_Protection_(ZZ133078)-Users-12-19-2012.xls
--Goes to Info Protection Report

-354_LRS-_Suicide_Awareness_(ZZ133113)-Users-12-19-2012.xls
--Goes to Suicide Prevention Report

-354_LRS-AEF_Pre--Deployment_Sexual_Assault_Prevention_and_Response_Training_Course-Users-12-19-2012.xls
--Goes to AEF Pre-Dep Sex Aslt Report

-354_LRS-AF_Counter-Improvised_Explosive_Device_(C-IED)_Awareness_(ZZ133095)_–_Jun_09-Users-12-19-2012.xls
--Goes to AF C-IED Report

-354_LRS-Air_Force_2A_Culture_General_Course_(ZZ133104)-Users-12-19-2012.xls
--Goes to AF 2A Culture Gen Report


That is everything, the dates at the end change depending on the date the report is pulled so it must be wild carded.

Thank you again John_w!

 

[John_w]

First is code which creates a lookup table of workbook names and associated sheet names (I used the workbook and sheet names from your other thread) on Sheet1 of the main workbook. You can expand the table either by editing and running the Create_Lookup routine or by typing in the names directly to the sheet. The workbook name in the lookup table is the workbook file name without the "-mm-dd-yyyy.xls" part.

Sub Create_Lookup()
    With Sheets("Sheet1")
        .Range("A1:B1").Value = Array("Workbook name without -mm-dd-yyyy date suffix", "Sheet Name")
        .Range("A2:B2").Value = Array("354_LRS-Air_Force_2A_Culture_General_Course_(ZZ133104)-Users", "Culture Gen Report")
        .Range("A3:B3").Value = Array("SERE_(V0970980)_REPORT", "SERE")
        .Range("A4:B4").Value = Array("SABC_(V1231231)_REPORT", "SABC CBT")
        .Range("A5:B5").Value = Array("SABC-Hands-On_(V91278901)_REPORT", "SABC Hands On")
    End With
End Sub

And here is the main code which uses the above lookup table to import each workbook to the correct sheet:

Sub Import_1st_Sheet_From_All_Workbooks_In_Folder2()

    Dim folder As String, fileName As String
    Dim thisWb As Workbook
    Dim WorkbookNameWithoutDate As String
    Dim Workbook_Sheet_Lookup As Range
    Dim findWorkbook As Range
    
    Set Workbook_Sheet_Lookup = Sheets("Sheet1").Columns("A")

    Set thisWb = ActiveWorkbook
    
    folder = ""
    With Application.FileDialog(msoFileDialogFolderPicker)
        If .Show = -1 Then folder = .SelectedItems(1)
    End With
    
    If folder <> "" Then
        fileName = Dir(folder & "\*.xls")
        While fileName <> ""
            WorkbookNameWithoutDate = Left(fileName, Len(fileName) - Len("-mm-dd-yyyy.xls"))
            
            Set findWorkbook = Workbook_Sheet_Lookup.Find(What:=WorkbookNameWithoutDate, After:=Workbook_Sheet_Lookup.Cells(1, 1), _
                LookIn:=xlValues, LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False, SearchFormat:=False)

            If Not findWorkbook Is Nothing Then
            
                'Import 1st sheet from workbook and rename sheet according to the lookup table
                
                Workbooks.Open folder & "\" & fileName
                With ActiveWorkbook
                    .Sheets(1).Copy After:=thisWb.Sheets(thisWb.Sheets.Count)
                    .Close savechanges:=False
                    thisWb.Sheets(thisWb.Sheets.Count).Name = findWorkbook.Offset(0, 1).Value
                End With
                
            Else
            
                MsgBox WorkbookNameWithoutDate & " not found in lookup range " & Workbook_Sheet_Lookup.Parent.Name & "!" & Workbook_Sheet_Lookup.Address
            
            End If
            
            fileName = Dir
        Wend
    End If
    
End Sub

 

[fiftimedun]

New code:

Sub Create_Lookup()
    With Sheets("Sheet1")
        .Range("A1:B1").Value = Array("Workbook name without -mm-dd-yyyy date suffix", "Sheet Name")
        .Range("A2:B2").Value = Array("354_LRS-Biometrics_Awareness_Course_(ZZ133117)-Users", "Biometrics Report")
        .Range("A3:B3").Value = Array("354_LRS-CBRN_Defense_Awareness_Course_v1.0_(ZZ133039),_Dec_2009-Users", "CBRNE v1.0 CBT Report")
        .Range("A4:B4").Value = Array("354_LRS-CBRN_Defense_Survival_Skills_Completion_(Hands-On)-Users", "CBRNE Hands-on Report")
        .Range("A5:B5").Value = Array("354_LRS-Collect_and_Report_Information_(20091007)_(ZZ133102)-Users", "Collect and Report Info Report")
        .Range("A6:B6").Value = Array("354_LRS-Communication_Engagement_Training_for_Deploying_Warfighters_(20091007)_(ZZ133099)-Users", "Comm Engagement Train Report")
        .Range("A7:B7").Value = Array("354_LRS-Don't_Ask,_Don't_Tell_Repeal_Training_--_Tier_3-Users", "DADT Report")
        .Range("A8:B8").Value = Array("354_LRS-Equal_Opportunity_and_Prevention_of_Sexual_Harassment_Deployment_Briefing_(20091007)_(ZZ133101)-Users", "EO & Prevent Sex Harass Report")
        .Range("A9:B9").Value = Array("354_LRS-Explosive_Ordnance_Reconnaissance_(EOR)_Course_v2.0_(ZZ133107),_Dec_09-Users", "EOR V2.0 Report")
        .Range("A10:B10").Value = Array("354_LRS-Law_of_Armed_Conflict_(LOAC)_-_2011-Users", "LOAC 2011 Report")
        .Range("A11:B11").Value = Array("354_LRS-Professional_and_Unprofessional_Relationships_(20091007)_(ZZ133103)-Users", "Pro Unpro Report")
        .Range("A12:B12").Value = Array("354_LRS-Self-Aid_and_Buddy_Care_(ZZ131008)-Users", "SABC CBT Report")
        .Range("A13:B13").Value = Array("354_LRS-Self-aid_Buddy_Care_(Hands-On)-Users", "SABC Hands On Report")
        .Range("A14:B14").Value = Array("354_LRS-SERE_100.1-Users", "SERE 100.1 Report")
        .Range("A15:B15").Value = Array("354_LRS-_DoD_Information_Assurance_Awareness_(ZZ133098)_v10-Users", "DoD IA Report")
        .Range("A16:B16").Value = Array("354_LRS-_Force_Protection_(ZZ133079)-Users", "Force Protection Report")
        .Range("A17:B17").Value = Array("354_LRS-_Human_Relations_(ZZ133080)-Users", "SABC Hands On")
        .Range("A18:B18").Value = Array("354_LRS-_Information_Protection_(ZZ133078)-Users", "Info Protection Report")
        .Range("A19:B19").Value = Array("354_LRS-_Suicide_Awareness_(ZZ133113)-Users", "Suicide Prevention Report")
        .Range("A20:B20").Value = Array("354_LRS-AEF_Pre-Deployment_Sexual_Assault_Prevention_and_Response_Training_Course-Users", "AEF Pre-Dp Sex Aslt Report")
        .Range("A21:B21").Value = Array("354_LRS-AF_Counter-Improvised_Explosive_Device_(C-IED)_Awareness_(ZZ133095)_-_Jun_09-Users", "C-IED Report")
        .Range("A22:B22").Value = Array("354_LRS-Air_Force_2A_Culture_General_Course_(ZZ133104)-Users", "AF 2A Culture Gen Report")
    End With
End Sub

Sub Import_1st_Sheet_From_All_Workbooks_In_Folder2()
    Dim folder As String, fileName As String
    Dim thisWb As Workbook
    Dim WorkbookNameWithoutDate As String
    Dim Workbook_Sheet_Lookup As Range
    Dim findWorkbook As Range
    
    Set Workbook_Sheet_Lookup = Sheets("Sheet1").Columns("A")
    Set thisWb = ActiveWorkbook
    
    folder = ""
    With Application.FileDialog(msoFileDialogFolderPicker)
        If .Show = -1 Then folder = .SelectedItems(1)
    End With
    
    If folder <> "" Then
        fileName = Dir(folder & "\*.xls")
        While fileName <> ""
            WorkbookNameWithoutDate = Left(fileName, Len(fileName) - Len("-mm-dd-yyyy.xls"))
            
            Set findWorkbook = Workbook_Sheet_Lookup.Find(What:=WorkbookNameWithoutDate, After:=Workbook_Sheet_Lookup.Cells(1, 1), _
                LookIn:=xlValues, LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False, SearchFormat:=False)
            If Not findWorkbook Is Nothing Then
            
                'Import 1st sheet from workbook and rename sheet according to the lookup table
                
                Workbooks.Open folder & "\" & fileName
                With ActiveWorkbook
                    .Sheets(1).Copy After:=thisWb.Sheets(thisWb.Sheets.Count)
                    .Close savechanges:=False
                    [COLOR=#ff0000]thisWb.Sheets(thisWb.Sheets.Count).Name = findWorkbook.Offset(0, 1).Value
[/COLOR]               End With
                
            Else
            
                MsgBox WorkbookNameWithoutDate & " not found in lookup range " & Workbook_Sheet_Lookup.Parent.Name & "!" & Workbook_Sheet_Lookup.Address
            
            End If
            
            fileName = Dir
        Wend
    End If
    
End Sub

I get the error that it:

"Cannot rename a sheet to the same name as another sheet, a referenced object library or a workbook referenced by Visual Basic."

It is trying to make new tabs instead of trying to copy them to the current tabs.

 

[John_w]

First, understand what the code does. It copies the first sheet from each source workbook to the master workbook, and then renames that sheet to the name (e.g. XXX) found in the lookup table. If sheet XXX already exists you will get that error when the imported sheet is renamed. What should it do if sheet XXX already exists? Should it overwrite the existing data, append to the end, rename as a different sheet name, or what? Please explain precisely what the code should do in this scenario.

 

[fiftimedun]

It should overwrite the existing, i tried a macro to delete the original report tabs then run your code, but deleting the existing tabs broke the formula links on another sheet. (turned them all to #REF)

 

[fiftimedun]

 Workbooks.Open folder & "\" & fileName
                With ActiveWorkbook
                    .Sheets(1).Copy After:=thisWb.Sheets(thisWb.Sheets.Count)
                    .Close savechanges:=False
                    thisWb.Sheets(thisWb.Sheets.Count).Name = findWorkbook.Offset(0, 1).Value
                End With

So what i need this to do is instead of copy to a new tab then rename is:

1. Copy to a new tab (currently doing)
2. Then copy the contents to the tab in accordance with the look up table (instead of trying to rename to the tab, just copy the data to the existing tab, (if not possible then can just use a copy range of A1:Z1000))
3. Lastly delete the originating tab

This code has far exceeded my capacity for changing easily, and i thank you very much John_w

 

[fiftimedun]

tried for a bit and this is as far as i got and i couldn't get it to work:

                With ActiveWorkbook
                    .Sheets(1).Copy After:=thisWb.Sheets(thisWb.Sheets.Count)
                    .Close savechanges:=False
                    thisWb.Sheets(thisWb.Sheets.Count).Range("A1:Z1000").Copy Destination:=findWorkbook.Offset(0, 1).Value
                    
                End With

got the error of:
Run-time error '1004':
Copy method of Range class failed

Then i tried this:

thisWb.Sheets(thisWb.Sheets.Count).Range("A1:Z1000").Copy Destination:=findWorkbook.Offset(0, 1).Range("A1")

That just messed up my sheet1...

 

[John_w]

So what i need this to do is instead of copy to a new tab then rename is:

1. Copy to a new tab (currently doing)
2. Then copy the contents to the tab in accordance with the look up table (instead of trying to rename to the tab, just copy the data to the existing tab, (if not possible then can just use a copy range of A1:Z1000))
3. Lastly delete the originating tab

Which boils down to overwriting the existing data, as you said in your previous reply. Try this version:

Sub Import_1st_Sheet_From_All_Workbooks_In_Folder2()

    Dim folder As String, fileName As String
    Dim thisWb As Workbook
    Dim WorkbookNameWithoutDate As String
    Dim Workbook_Sheet_Lookup As Range
    Dim findWorkbook As Range
    Dim sheetName As String
    
    Set thisWb = thisWorkbook
    
    Set Workbook_Sheet_Lookup = thisWb.Worksheets("Sheet1").Columns("A")
    
    folder = ""
    With Application.FileDialog(msoFileDialogFolderPicker)
        If .Show = -1 Then folder = .SelectedItems(1)
    End With
    
    If folder <> "" Then
        fileName = Dir(folder & "\*.xls")
        While fileName <> ""
            WorkbookNameWithoutDate = Left(fileName, Len(fileName) - Len("-mm-dd-yyyy.xls"))
            
            Set findWorkbook = Workbook_Sheet_Lookup.Find(What:=WorkbookNameWithoutDate, After:=Workbook_Sheet_Lookup.Cells(1, 1), _
                LookIn:=xlValues, LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False, SearchFormat:=False)

            If Not findWorkbook Is Nothing Then
            
                'Import 1st sheet from workbook copy/rename sheet according to the lookup table
                
                Workbooks.Open folder & "\" & fileName
                With ActiveWorkbook
                
                    sheetName = findWorkbook.Offset(0, 1).Value
                    If WorksheetExists(thisWb, sheetName) Then
                    
                        'Sheet already exists, so copy source sheet cells to existing sheet, overwriting existing cells
                        
                        .Sheets(1).Range("A1:Z1000").Copy thisWb.Sheets(sheetName).Range("A1")
                        
                    Else
                    
                        'Sheet doesn't exist, so copy source sheet to a new sheet in this workbook and rename the imported sheet
                    
                        .Sheets(1).Copy After:=thisWb.Sheets(thisWb.Sheets.Count)
                        thisWb.Sheets(thisWb.Sheets.Count).Name = sheetName
                    End If
                        
                    .Close savechanges:=False
                    
                End With
                
            Else
            
                MsgBox WorkbookNameWithoutDate & " not found in lookup range " & Workbook_Sheet_Lookup.Parent.Name & "!" & Workbook_Sheet_Lookup.Address
            
            End If
            
            fileName = Dir
        Wend
    End If
    
End Sub


Private Function WorksheetExists(Wb As Workbook, WorksheetName As String) As Boolean
    On Error Resume Next
    WorksheetExists = Wb.Worksheets(WorksheetName).Name <> ""
    On Error GoTo 0
End Function