Import multiple excel Worksheet / workbook to a single table in Access 2010

[tunna991]

This is a situation I recently encountered. My department has over 500 excel files with multiple tabs. We want to import the data from specific tabs into one excel database. These tabs will contain the same columns. I am not good with VBA and could not find a solution after much googling.

Also each excel file has an information tab from which I want to extract data from and populate with the data I am importing. This information file lists the date and location in separate cells.

I hope I am making sense here.

 

[SkipVought]

Hi,

We’ll try to get you started.

What specific tabs?

Do all these tabs have tables that have Headings that start in A1?

Are all 500 workbooks in one folder?

Skip,

_{Just traded in my OLD subtlety...
for a NUance!}

 

[tunna991]

There are 5 tabs out of the 9 I need in from there. Yes they all have headings that start in A1. Yes and all 500 files will be in one folder.

Thank you kindly for your help.

 

[SkipVought]

Great.

How about the information tab name?

What specific information needs to be captured and how is this data mapped to the output table?

How conversant are you with 1) Excel or 2) Excel VBA?

What languages do you program in?

Skip,

_{Just traded in my OLD subtlety...
for a NUance!}

 

[tunna991]

Great.

How about the information tab name?

Basically the users download this report from a larger reporting system. The information tab contains information like date of report and the name of the location.

Basically for each excel file I import into access, I would like to capture the date and location name from the information tab. This will sort of help identify the month and location of the date.

I am mediocre with Excel VBA.

My though process is to migrate the files firstly by combining all the excel files into one large excel file, then moving that to access. Please suggest a better way.

 

[SkipVought]

Well so far your answers have been nebulous. Maybe you just want some pointers. That will work just fine.

I agree with your approch.

I’d start by creating a new workbook for this conglomerate table. Set up the table headings.

In this worbook you will code this procedure, starting with a File System Object to use to loop through the single folder where your 500/files reside.

As you loop each file is opened.

You loop through each sheet in the open workbook capturing the DATA from the 5 sheets and pasting into the target workbook table, (the workbook containg your VBA code) in the next row of the table, and finally close the source workbook.

I’ll be available to help you with tips and other suggestions as requested. Good luck!

Skip,

_{Just traded in my OLD subtlety...
for a NUance!}

 

[Andrzejek]

Please consider using TGML tags to format your code - an icon just above the box where you type your post/replies. Don't you agree this way is a lot easier to read....?

[green]' Correct number of sheets[/green]
 Application.DisplayAlerts = False

 If ThisWorkbook.Sheets.Count < NUMBER_OF_SHEETS Then
     ThisWorkbook.Sheets.Add Count:=NUMBER_OF_SHEETS - ThisWorkbook.Sheets.Count
 ElseIf ThisWorkbook.Sheets.Count > NUMBER_OF_SHEETS Then
     For i = ThisWorkbook.Sheets.Count To NUMBER_OF_SHEETS + 1 Step -1
         ThisWorkbook.Sheets(i).Delete
     Next i
 End If

 Application.DisplayAlerts = True

---- Andy

There is a great need for a sarcasm font.

 

[SkipVought]

OOPS, Sorry
I corrected the Copy statement.

Here's an example of multiple sheet names for selective processing. This code also performs most of what you need, I believe...

Sub MAIN_COPY()
    Dim oFSO As Object, oFile As Object
    Dim ws As Worksheet, wsOUT As Worksheet
    Dim lRowOUT As Long, sFolderSpec As String
    
    Set oFSO = CreateObject("Scripting.FileSystemObject")
'put your OUTPUT workbook name here
    Set wsOUT = Worksheets("Name of your output table sheet")
'put the path to the INPUT file folders here
    sFolderSpec = "\\SKIPSPC\Users\Skip\Documents\TT"
    
    For Each oFile In oFSO.GetFolder(sFolderSpec).Files
        With Workbooks.Open(oFile.Path)
            For Each ws In .Worksheets
                With ws
                    Select Case .Name
[b]'put your 5 worksheet names here
                        Case "Your", "5", "sheet", "names", "here"[/b]
                            Intersect(.Range(.Cells(2, 1), .Cells(.Cells.Rows.Count, 1)).EntireRow, .UsedRange).Copy
                    
                            With wsOUT
                                lRowOUT = .Cells(.Cells.Rows.Count, 1).End(xlUp) + 1
                                .Cells(lRowOUT, 1).PasteSpecial xlPasteValues
                            End With
                    End Select
                End With
            Next
            .Close
        End With
    Next
End Sub

Skip,

_{Just traded in my OLD subtlety...
for a NUance!}

 

[tunna991]

Thanks for the code Skip.

I will try this when I get to work.

How would I add in another row and populate it with a value from a sheet from the file I am merging from?

 

[SkipVought]

Your questions and answers are very vague. What happens in vagueness, stays in vagueness. ;-)

You want to add a row and “populate it with a value from a sheet from the file I am merging from“?

Can you explain that because it doesn’t make sense to me.

Skip,

_{Just traded in my OLD subtlety...
for a NUance!}

 

[tunna991]

Very sorry for the confusion. How exactly do I use the TGML tags? I clicked the TGML checkbox and it seems to be making no differece.

 

[tunna991]

OK so the below code pasted should look better for the eyes

Now regarding the earlier point I am including an attachment to make things more clear. Just for privacy reason I have changed the labels and data drastically

The file is at

http://files.engineering.com/getfil...92f724a&file=Sample_-_Kirkland_CM_Office.xlsx

When you open the file, you can see the different tabs that I want to merge (Medicines, Disasters, Rescues, Dentals) into one master sheet. The code below is doing that just fine.

Also I want to add three addition columns for every record (Date From, Date To, Service Delivery Agent). The value for this will come from the information tab from the respective cells.

Currently the code is adding an extra column (File Name) and adding the actual file name for it.

This is where I am stuck at.

Option Explicit
Const NUMBER_OF_SHEETS = 7

Public Sub GiantMerge()
    Dim externWorkbookFilepath As Variant
    Dim externWorkbook As Workbook
    Dim i As Long
    Dim mainLastEnd(1 To NUMBER_OF_SHEETS) As Range
    Dim mainCurEnd As Range


    Application.ScreenUpdating = False

    ' Initialise

    ' Correct number of sheets
    Application.DisplayAlerts = False
    If ThisWorkbook.Sheets.Count < NUMBER_OF_SHEETS Then
        ThisWorkbook.Sheets.Add Count:=NUMBER_OF_SHEETS - ThisWorkbook.Sheets.Count
    ElseIf ThisWorkbook.Sheets.Count > NUMBER_OF_SHEETS Then
        For i = ThisWorkbook.Sheets.Count To NUMBER_OF_SHEETS + 1 Step -1
            ThisWorkbook.Sheets(i).Delete
        Next i
    End If
    Application.DisplayAlerts = True

    For i = 1 To NUMBER_OF_SHEETS
        Set mainLastEnd(i) = GetTrueEnd(ThisWorkbook.Sheets(i))
    Next i


    ' Load the data
    For Each externWorkbookFilepath In GetWorkbooks()
        Set externWorkbook = Application.Workbooks.Open(externWorkbookFilepath, , True)

        For i = 1 To NUMBER_OF_SHEETS

            If mainLastEnd(i).Row > 1 Then
                ' There is data in the sheet

                ' Copy new data (skip headings)
                externWorkbook.Sheets(i).Range("A2:" & GetTrueEnd(externWorkbook.Sheets(i)).Address).Copy ThisWorkbook.Sheets(i).Cells(mainLastEnd(i).Row + 1, 1)

                ' Find the end column and row
                Set mainCurEnd = GetTrueEnd(ThisWorkbook.Sheets(i))
            Else
                ' No nata in sheet yet (prob very first run)

                ' Get correct sheet name from first file we check
                ThisWorkbook.Sheets(i).Name = externWorkbook.Sheets(i).Name

                ' Copy new data (with headings)
                externWorkbook.Sheets(i).Range("A1:" & GetTrueEnd(externWorkbook.Sheets(i)).Address).Copy ThisWorkbook.Sheets(i).Cells(mainLastEnd(i).Row, 1)

                ' Find the end column and row
                Set mainCurEnd = GetTrueEnd(ThisWorkbook.Sheets(i)).Offset(, 1)

                ' Add file name heading
                ThisWorkbook.Sheets(i).Cells(1, mainCurEnd.Column).Value = "Date From"
            End If

            ' Add file name into extra column
            ThisWorkbook.Sheets(i).Range(ThisWorkbook.Sheets(i).Cells(mainLastEnd(i).Row + 1, mainCurEnd.Column), mainCurEnd).Value = externWorkbook.Name

            Set mainLastEnd(i) = mainCurEnd
        Next i

        externWorkbook.Close
    Next externWorkbookFilepath

    Application.ScreenUpdating = True
End Sub

' Returns a collection of file paths, or an empty collection if the user selects cancel
Private Function GetWorkbooks() As Collection
    Dim fileNames As Variant
    Dim xlFile As Variant

    Set GetWorkbooks = New Collection

    fileNames = Application.GetOpenFilename(Title:="Please choose the files to merge", _
                                               FileFilter:="Excel Files, *.xls;*.xlsx", _
                                               MultiSelect:=True)
    If TypeName(fileNames) = "Variant()" Then
        For Each xlFile In fileNames
            GetWorkbooks.Add xlFile
        Next xlFile
    End If
End Function

' Finds the true end of the table (excluding unused columns/rows and rows filled with 0's)
Private Function GetTrueEnd(ws As Worksheet) As Range
    Dim lastRow As Long
    Dim lastCol As Long
    Dim r As Long
    Dim c As Long

    On Error Resume Next
    lastCol = ws.UsedRange.Find("*", , , xlPart, xlByColumns, xlPrevious).Column
    lastRow = ws.UsedRange.Find("*", , , xlPart, xlByRows, xlPrevious).Row
    On Error GoTo 0

    If lastCol <> 0 And lastRow <> 0 Then

        ' look back through the last rows of the table, looking for a non-zero value
        For r = lastRow To 1 Step -1
            For c = 1 To lastCol
                If ws.Cells(r, c).Text <> "" Then
                    If ws.Cells(r, c).Text <> 0 Then
                        Set GetTrueEnd = ws.Cells(r, lastCol)
                        Exit Function
                    End If
                End If
            Next c
        Next r
    End If

    Set GetTrueEnd = ws.Cells(1, 1)
End Function

 

[SkipVought]

FINALLY, looking at an example of your tables.

Empty rows in a table???!!!

Say it ain't so, Joe!

faq68-5184

While you clean up your data and make your tables legal, I'm working on getting data from Information to your table.

Skip,

_{Just traded in my OLD subtlety...
for a NUance!}

 

[SkipVought]

Hey, I’m coding a procedure to delete the empty rows. So don’t sweat that.

In the future, don't shoot yourself in the foot by inserting empty rows in any working table.

Excel features won’t work for you in such a table.

Skip,

_{Just traded in my OLD subtlety...
for a NUance!}

 

[SkipVought]

This code example has the additional facility to copy the From:, To: and Agent: to the Output Table.

Included is the procedure to Delete empty rows.

And the three additional column headings are From:, To:, Agent: as in the sINFO array.

Sub MAIN()
'ShipVought 2018 APR 4
'loops thru a specified folder containing Excel source workbooks
'OPENS each source workbook
'Loops thru each source worksheet
'copies data from selected worksheets to output table
'stores selected data from Information sheet and propagates data in output table to all rows for source workbook
'closes source workbook
    Dim oFSO As Object, oFile As Object     'file system objects
    Dim ws As Worksheet                     'worksheet variable for source workbooks
    Dim wsOUT As Worksheet                  'output table worksheet
    Dim rINFO As Range                      'heading range for additional information columns
    Dim lRowOUT As Long                     'next row in output table
    Dim sFolderSpec As String               'your folder path
    Dim rFound As Range                     'range variable to find From:, To:, Agent:
    Dim sINFO(2, 1) As Variant              'array for data from Information
    Dim i As Integer                        'array index
    Dim iCOL As Integer                     'last column in output table
    
    sINFO(0, 0) = "From:"
    sINFO(1, 0) = "To:"
    sINFO(2, 0) = "Agent:"
    
    Set oFSO = CreateObject("Scripting.FileSystemObject")
    
    Set wsOUT = Worksheets("Master")
'put your folder path here
    sFolderSpec = "\\SKIPSPC\Users\Skip\Documents\TT\Test"
    
    With wsOUT
        iCOL = .Cells(1, 1).End(xlToRight).Column
        Set rINFO = .Range(.Cells(1, iCOL - UBound(sINFO)), .Cells(1, iCOL))
    End With
    
    For Each oFile In oFSO.GetFolder(sFolderSpec).Files
        With Workbooks.Open(oFile.Path)
        
            'call macro to delete empty rows in source workbook
            DeleteEmptyRows .Sheets(1).Parent
            
            'loop through each sheet in source workbook
            For Each ws In .Worksheets
                With ws
                    Select Case .Name
                    
                        'only copy these sheets to output table
                        Case "Medicines", "Disasters", "Rescues", "Dentals"
                            Intersect(.Range(.Cells(2, 1), .Cells(.Cells.Rows.Count, 1)).EntireRow, .UsedRange).Copy

                            With wsOUT
                                lRowOUT = .Cells(.Cells.Rows.Count, 1).End(xlUp).Row + 1
                                .Cells(lRowOUT, 1).PasteSpecial xlPasteAll
                            End With
                            
                        'fill array from Information
                        Case "Information"
                            For i = 0 To UBound(sINFO)
                                Set rFound = .Columns(1).Find(sINFO(i, 0))

                                If Not rFound Is Nothing Then
                                    sINFO(i, 1) = rFound.Offset(0, 1).Value
                                End If
                            Next
                    End Select
                End With
            Next
            
            'close the workbook without saving
            Application.DisplayAlerts = False
            .Close
            Application.DisplayAlerts = True
        End With
            
        'put the data from Information into output table
        With wsOUT
            lRowOUT = .Cells(.Cells.Rows.Count, iCOL).End(xlUp).Row + 1
            
            'put the values in the right-hand columns
            For i = 0 To UBound(sINFO)
                .Cells(lRowOUT, iCOL + i - UBound(sINFO)).Value = sINFO(i, 1)
            Next
            
            'copy the values down to the last row in the output table
            Intersect(rINFO.EntireColumn, .Rows(lRowOUT)).Copy _
            Intersect(rINFO.EntireColumn, _
                .Range(.Cells(lRowOUT, 1), .Cells(.UsedRange.Rows.Count, 1)).EntireRow)
        End With
    Next
End Sub

Sub DeleteEmptyRows(wb As Workbook)
    Dim ws As Worksheet

    For Each ws In wb.Worksheets
    
        'if the row count NOT EQUAL to a count of values in column 1 then we have empty rows
        If ws.UsedRange.Rows.Count <> Application.CountA(ws.Columns(1)) Then
        
            Select Case ws.Name
                Case "Information"
                Case Else
                    'delete empty rows for all sheets other than Information
                    With ws.UsedRange
                        .AutoFilter
                        .AutoFilter Field:=1, Criteria1:="="
                        Intersect(ws.Range(ws.Cells(2, 1), ws.Cells(ws.Cells.Rows.Count, 1)).EntireRow, .Cells).Delete xlUp
                        .AutoFilter
                    End With
            End Select
        End If
    Next
End Sub

Skip,

_{Just traded in my OLD subtlety...
for a NUance!}

 

[tunna991]

Hi Skip.

' It says subsscript out of range when it comes to the following line.

Set oFSO = CreateObject("Scripting.FileSystemObject")

 

[tunna991]

Actually it stops at this line...

Set wsOUT = Worksheets("Master")

 

[SkipVought]

I don't know why. I just now ran my copy without error.

do you have a Sheet named Master in the workbook running this procedure where the output table resides?

Skip,

_{Just traded in my OLD subtlety...
for a NUance!}

 

[tunna991]

Your code is almost getting me there.

The thing that is not working are the three extra columns I need to capture from the information tab. Also it crashes when the folder has multiple files.

 

[tunna991]

Is there any way you can help me to modify the code I posted initally. I know it doesnt have the delete blanks function, I can figure that part out later.