VBA for importing data from multiple wordbooks to one sheet

[masud8956]

Hi,

I have some data within the range F78:U797 (16 columns and 720 rows) in multiple workbooks kept in one folder (C:\Desktop).

I need a VBA help to import those data from all those wordbooks in that folder automatically in a separate MASTER worksheet for further processing. One column has "date"inputs; so I would like to have the list in chronological order too.

Thanks in advance!

 

[masud8956]

You are very welcome.

Hi @mumps!

Its been a while! You have tried to solve one of my problem with a lot of patience and finally I thought solution was #68 . I posted an incomplete code and you modified it as per my requirement. I did not notice that this code that I provided had one problem, the last row with value from each source file do not get imported.

I checked again that the code you provided me earlier was working better (#38). Would you please do a little modification so that the data get pasted at A1 instead of B2. And I do not need the "Serial No" at Column B and the Headers (Which you included as I asked for those). I simply need Range G77:U196 to be imported at DATA sheet starting at A1.

See what I mean in the pic below:

https://www.dropbox.com/s/82ws3pl2n42ugdh/Untitled.jpg?dl=0

I am putting the code that you provided below:

[COLOR=#333333]Sub CopyRange()[/COLOR]    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    Dim lastRow As Long
    Dim wkbDest As Workbook
    Dim wkbSource As Workbook
    Set wkbDest = ThisWorkbook
    Const strPath As String = "D:\Aircrew_Flying_Hour\"
    Sheets("DATA").UsedRange.ClearContents
    ChDir strPath
    strExtension = Dir(strPath & "*.xlsx")
    Application.DisplayAlerts = False
    Do While strExtension <> ""
        Set wkbSource = Workbooks.Open(strPath & strExtension, UpdateLinks:=False)
        If wkbSource.name <> ThisWorkbook.name Then
            With wkbSource
                '.Sheets("Summary of the Year").Unprotect Password:="2501"
                .Sheets("Summary of the Year").Range("F76:U76").Copy wkbDest.Sheets("DATA").Cells(1, 2)
                .Sheets("Summary of the Year").Range("G77:U796").Copy
                wkbDest.Sheets("DATA").Cells(Rows.Count, "C").End(xlUp).Offset(1, 0).PasteSpecial xlPasteValues
                .Close savechanges:=False
            End With
            strExtension = Dir
        End If
    Loop
    Application.DisplayAlerts = True
    lastRow = wkbDest.Worksheets("DATA").Cells(Rows.Count, "D").End(xlUp).Row
    wkbDest.Sheets("DATA").Range("B1:Q" & lastRow).AutoFilter Field:=3, Criteria1:="="
    wkbDest.Sheets("DATA").Range("B2:Q" & lastRow).SpecialCells(xlCellTypeVisible).EntireRow.Delete
    If wkbDest.Sheets("DATA").AutoFilterMode Then wkbDest.Sheets("DATA").AutoFilterMode = False
    With wkbDest.Sheets("DATA").Range("B2")
        .Value = "1"
        .AutoFill Destination:=Range("B2").Resize(Range("D" & Rows.Count).End(xlUp).Row), Type:=xlFillSeries
    End With
    lastRow = wkbDest.Worksheets("DATA").Cells(Rows.Count, "D").End(xlUp).Row
    wkbDest.Worksheets("DATA").Sort.SortFields.Clear
    wkbDest.Worksheets("DATA").Sort.SortFields.Add Key:=Range("C2:C" & lastRow) _
        , SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    With wkbDest.Worksheets("DATA").Sort
        .SetRange Range("C1:C" & lastRow)
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
    Application.Calculation = xlCalculationAutomatic
    Application.ScreenUpdating = True [COLOR=#333333]End Sub[/COLOR]

Thanks!

 

[mumps]

This is a very long thread and to be honest, I don't have the time to review each of the 70 posts to refresh my memory. Could you upload copies of the necessary files and explain again in detail what you want to accomplish, particularly the changes you want made. Include in your files the macros that are working for you that you want revised. It would be a great help if you could manually create a sheet that shows the end result that you expect.

 

[masud8956]

Yeah sure! I will explain as best as I can. Please disregard the problem I mentioned at #71 for now.

I have some data within the range G77:U796 (16 columns and 720 rows) in the same sheet of multiple workbooks (identical in configuration) kept in one folder.

I requested for a VBA help to import those data from all those wordbooks in that folder automatically (when file opened) in a separate worksheet named "MASTER_CALCULATOR" for further processing.

1. The source folder name is Aircrew_Flying_Hour. Location> D:\Aircrew_Flying_Hour\.

2. Source file extensions are xlsx.

3. Sheet names of the input range are identical. All source files are identical. The source sheet name is "Summary of the Year" ('Sheet 16' of each source file).

4. Destination wordbook has 4 sheets. 1st sheet named "DATA" (Sheet 1) where I wanted the data to be imported. The destination file (named MASTER_CALCULATOR) is also located in the same folder with source files.

The code you helped me with worked nicely and runs very fast as well.

Sub Test()    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
[COLOR=#ee82ee]    Sheets("DATA").Cells.ClearContents[/COLOR]
    Dim lastRow As Long
    Dim firstRow As Long
    Dim myDir As String, fn As String, n As Long, t As Long, Cell As String
    Const wsName As String = "Summary of the Year"
    Const myRng As String = "G77:U796"
    myDir = "D:\Aircrew_Flying_Hour"
    fn = Dir(myDir & "\*.xlsx")
    If fn = "" Then MsgBox "No files in the folder": Exit Sub
    With Range(myRng)
        n = .Rows.Count: t = .Columns.Count
        Cell = .Cells(1).Address(0, 0)
    End With
    Do While fn <> ""
        With Sheets("Data").Range("a" & Rows.Count).End(xlUp)(1).Resize(n, t)
            
            .Formula = "=if('" & myDir & "\[" & fn & "]" & wsName & "'!" & Cell & "<>""""," & _
                       "'" & myDir & "\[" & fn & "]" & wsName & "'!" & Cell & ","""")"
            .Value = .Value
        End With
        fn = Dir
    Loop
    firstRow = Sheets("DATA").Range("A1:A" & Sheets("DATA").Rows.Count).Cells.SpecialCells(xlCellTypeBlanks).Row
    lastRow = Sheets("DATA").Cells(Rows.Count, "A").End(xlUp).Row
    Sheets("DATA").Range("A" & firstRow & ":A" & lastRow).AutoFilter Field:=1, Criteria1:="="
[COLOR=#ff0000]    Sheets("DATA").Range("A" & firstRow & ":A" & lastRow).SpecialCells(xlCellTypeVisible).EntireRow.Delete[/COLOR]
    If Sheets("DATA").AutoFilterMode Then Sheets("DATA").AutoFilterMode = False
    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic
End Sub

The DATA sheet looks like:

https://www.dropbox.com/s/k3dmm39spsedmjb/Screenshot_2.jpg?dl=0

I have 2 problems though:

1. At present, I have a total of 19 source files in that folder. It seems somehow one row from each file has not been imported. I have counted individually there should be 1860 rows but in DATA sheet I see 1842 rows as you can see in the pic below:

https://www.dropbox.com/s/p3pxbnh422qua3f/Screenshot_4.jpg?dl=0

Maybe there is some tiny glitch in the code.

2. I have another 3 sheets apart from "DATA" sheet in my MASTER_CALCULATOR file. As the code runs automatically once I open the MASTER file (I wanted it this way), the cells with formulas in those 3 sheets which are linked with DATA sheet turns #REF !. I would like to have my hyperlinks retained even after I run the code.

Is it because we have used "ClearContents" in the 3rd line of the code (violet text) to get rid of any previous data. But in last but 5th line (red text) it says "EntireRow.Delete"? I could not figure out why.

Please let me know if you need any more information.

Thanks and regards!

 

[mumps]

Rather than pictures, could you upload the actual MASTER_CALCULATOR file and a couple of the source files. This would allow me to test the macro.

 

[masud8956]

Sure!

Here are 2 of the source files that are located in D:\Aircrew_Flying_Hour\

https://www.dropbox.com/s/rbvon7m4cqy67h8/Aircrew%20Flying%20Hour-2003.xlsx?dl=0

https://www.dropbox.com/s/p6lt3b18b5i1mls/Aircrew%20Flying%20Hour-2004.xlsx?dl=0

And here is the Master file:

https://www.dropbox.com/s/ov270pnxg6h41z1/MASTER_CALCULATOR.xlsm?dl=0

It is good for me if the source format of the data can be retained while import.

Thanks.

 

[masud8956]

@mumps

With ref to the attached files above I think I can explain better:

There are 2 source files attached.

1. Aircrew Flying Hour-2003
2. Aircrew Flying Hour-2004

The macro should return 34 rows from 1st file (Aircrew Flying Hour-2003) and 78 rows from 2nd file (Aircrew Flying Hour-2004) excluding blank rows from both the source files.

I ran the code with a variable number of source files in the folder.

When I run the code with only one file (Aircrew Flying Hour-2003) in the folder 34 rows are returned just fine.

But when I run the code with 2 files (Aircrew Flying Hour-2003 and Aircrew Flying Hour-2004) in the folder, 33 rows (1 row less) are returned from the 1st file (Aircrew Flying Hour-2003) and 78 rows from the 2nd file (Aircrew Flying Hour-2004)

If I add a 3rd file in the folder it ultimately causes 1 less row to be returned from the 2nd file (Aircrew Flying Hour-2004). And this goes on with an increment in a number of files in the source files. Thereby as I have 19 files in the folder (and growing) now a total of 18 rows are not returned.

The missing row appears to be the last row with values of the respective files.

 

[mumps]

Try:

Sub test()
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    Sheets("DATA").Cells.ClearContents
    Dim lastRow As Long
    Dim firstRow As Long
    Dim myDir As String, fn As String, n As Long, t As Long, Cell As String
    Const wsName As String = "Summary of the Year"
    Const myRng As String = "G77:U796"
    myDir = "D:\Aircrew_Flying_Hour"
    fn = Dir(myDir & "\*.xlsx")
    If fn = "" Then MsgBox "No files in the folder": Exit Sub
    With Range(myRng)
        n = .Rows.Count: t = .Columns.Count
        Cell = .Cells(1).Address(0, 0)
    End With
    Do While fn <> ""
        With Sheets("Data").Range("A" & Rows.Count).End(xlUp).Offset(1, 0).Resize(n, t)
            .Formula = "=if('" & myDir & "\[" & fn & "]" & wsName & "'!" & Cell & "<>""""," & _
                       "'" & myDir & "\[" & fn & "]" & wsName & "'!" & Cell & ","""")"
            .Value = .Value
        End With
        fn = Dir
    Loop
    firstRow = Sheets("DATA").Range("A1:A" & Sheets("DATA").Rows.Count).Cells.SpecialCells(xlCellTypeBlanks).Row
    lastRow = Sheets("DATA").Cells(Rows.Count, "A").End(xlUp).Row
    Sheets("DATA").Range("A" & firstRow & ":A" & lastRow).AutoFilter Field:=1, Criteria1:="="
    Sheets("DATA").Range("A" & firstRow & ":A" & lastRow).SpecialCells(xlCellTypeVisible).EntireRow.Delete
    If Sheets("DATA").AutoFilterMode Then Sheets("DATA").AutoFilterMode = False
    Sheets("DATA").Range("A1:O" & Sheets("DATA").Range("A" & Sheets("DATA").Rows.Count).End(xlUp).Row).Copy Sheets("DATA COPY").Range("A1")
    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic
End Sub

 

[masud8956]

@mumps

Excellent code!

Now the data import is exactly the way I wanted! None of the rows are missing and #REF ! errors are gone.

I noticed the line towards the end of the code:

Sheets("DATA").Range("A1:O" & Sheets("DATA").Range("A" & Sheets("DATA").Rows.Count).End(xlUp).Row).Copy Sheets("DATA COPY").Range("A1")

I don't know, probably you have added this to get rid of #REF ! error.

A tiny problem remains though:

I ran the code with both the files in the source folder first. The 1st sheet "DATA" imported 34+78=112 rows as expected. The same was copied to the 2nd sheet "DATA COPY". Since my 3rd and 4th sheet cells are hyperlinked to 2nd sheet (DATA COPY), all my calculations are perfect. File attached below (after 1st run with both files in the folder):

https://www.dropbox.com/s/2ztycv8iit4cdai/MASTER_CALCULATOR 1.xlsm?dl=0

Then I removed the 1st file from the folder (Aircrew Flying Hour-2003) and ran the code for the 2nd time only with the 2nd file (Aircrew Flying Hour-2004) in the source folder. Again the 1st sheet "DATA" imported 78 rows as expected. The same was copied to the 2nd sheet "DATA COPY". But now in "DATA COPY" sheet from row 79 to row 112 the previous data from my 1st run (with both files in the folder) remained. File attached below (after 2nd run with one file in the folder "Aircrew Flying Hour-2004"). Please notice "DATA COPY" sheet (red bordered area):

https://www.dropbox.com/s/w7usfwjpqqnds4n/MASTER_CALCULATOR 2.xlsm?dl=0

I understand this problem would not occur if I just kept increasing number of source files in the folder rather than reducing.

Can it be modified to make "DATA" and "DATA COPY" sheets to look the same in terms of cell values?

I really appreciate your effort for me and can't thank you enough! Feeling like "Almost Home"!!

 

[mumps]

Try adding this line of code:

Sheets("DATA COPY").Cells.ClearContents

below this line:

If Sheets("DATA").AutoFilterMode Then Sheets("DATA").AutoFilterMode = False

 

[masud8956]

Hi @mumps!

Satisfied...100% with 200% gratitude!

The code works like magic, just the way I wanted or maybe even better.

Thanks for your patience and attention.