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!

 

[klutch]

@mumps oops sorry! Thanks for letting me know.

 

[mumps]

No problem. You may want to take a minute to review the rules at this link: https://www.mrexcel.com/forum/board-announcements/99490-forum-rules.html

 

[masud8956]

Try this macro. For sorting purposes, the macro assumes the dates are in column G of the "DATA" sheet. Change the column in the code to suit your needs. Change "MyPassword" in the code to your actual password.

Hi! Thanks for your effort.

It still doesn't work. I get the warning "This wordbook contains one or more links that cannot be updated" continuously. I tried to stop the warning by "Edit link" but it keeps popping up. Finally the warning stopped but again I get arbitrary data in many cells.

BTW I meant that the cells containing the data at source files are in hidden form.

Thanks for your quick reply!

 

[mumps]

At this point, it would be helpful to see what your data looks like. Please refer to Post #11 for instructions on how to upload copies of your file.

 

[masud8956]

Okay,

Here are 2 of 18 of the files:

https://www.dropbox.com/s/e8vzl2axfcl4evy/Aircrew Flying Hour-2006.xlsx?dl=0
https://www.dropbox.com/s/cb51q1ko53p0gzl/Aircrew Flying Hour-2007.xlsx?dl=0

And the Destination file:

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

I am trying to extract F77:U796 (excluding headers) of the "Summary of the Year" sheets of each file in the folder and paste to "DATA" sheet of destination file "MASTER_CALCULATOR".

It is helpful for me if the code includes cmmand:

1. To avoid any warnings
2. To erase existing data and run the code afresh every time I open the file.

 

[mumps]

Your source files have a lot of rows with no data in F76:U796. Do you want to copy only the rows with data into the Master or the entire range including the blank cells? You want the data to be copied over when you open the Master workbook. Is this correct?

 

[masud8956]

Your source files have a lot of rows with no data in F76:U796. Do you want to copy only the rows with data into the Master or the entire range including the blank cells? You want the data to be copied over when you open the Master workbook. Is this correct?

You are absolutely correct. I want automatic copy upon opening the file.

Those blanks are necessary. I need the whole range as it is. (Or discarding the blanks is okay but for any value anywhere in a row; i need the whole row as it is)

 

[mumps]

Try this macro. I have disabled the line of code that unprotects the "Summary of the Year" sheet. You can enable that line if you need it by removing the apostrophe at the beginning. The macro also sorts The "DATA" sheet by the date in column C. It also copies the formulas from your source files. If you don't want the formula to be copied, let me know and I will modify the macro.

Sub CopyRange()
    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")
    Do While strExtension <> ""
        Set wkbSource = Workbooks.Open(strPath & strExtension)
        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("F77:U796").Copy wkbDest.Sheets("DATA").Cells(Rows.Count, "B").End(xlUp).Offset(1, 0)
                .Close savechanges:=False
            End With
            strExtension = Dir
        End If
    Loop
    lastRow = wkbDest.Worksheets("DATA").Cells(Rows.Count, "C").End(xlUp).Row
    wkbDest.Worksheets("DATA").Sort.SortFields.Clear
    wkbDest.Worksheets("DATA").Sort.SortFields.Add Key:=Range("C2:C" & lastRow) _
        , SortOn:=xlSortOnValues, Order:=xlDescending, 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
End Sub

 

[masud8956]

Thanks for your tireless effort! Really appreciate it!!

Few problems after I ran the code:

1. Still I am getting a warning 16/17 times before any data is pasted to destination.
2. Some unwanted text appearing in the data matrix (Row 44 onward e.g. NIGHT, DAY, FUNCTIONAL etc whereas all data are durations)
3. All dates are appearing as 0 Jan 00 and all the durations as 0:00

I am uploading the link of the end result. Also added a screenshot of the warning right side of the table at the top.

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

Thanks again!

 

[mumps]

Because the macro also copies the formulas from the source files, the cells on the "DATA" sheet are all results of the formulas so you will have to look at your formulas. Try the following macro. If will copy and paste the values only. Does this works for you?

Sub CopyRange()
    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
    Const strPath As String = "C:\Test2\"
    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("F77:U796").Copy
                wkbDest.Sheets("DATA").Cells(Rows.Count, "B").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, "C").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
End Sub