VBA for importing data from multiple wordbooks to one sheet

masud8956

masud8956

Board Regular
Joined
Oct 22, 2016
Messages
163
Office Version
  1. 2016
  2. 2011
  3. 2007
Platform
  1. Windows
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!
 
Last edited:
Sort by date Sort by votes

Excel Facts

Add Bullets to Range
Select range. Press Ctrl+1. On Number tab, choose Custom. Type Alt+7 then space then @ sign (using 7 on numeric keypad)
The dropbox link was working before but now it isn't and I don't know why. Perhaps you could try www.box.com
 
Upvote 0
This macro worked for me on the last 3 files you posted:
Code: 
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\"
    Application.DisplayAlerts = False
    Sheets("DATA").Delete
    Application.DisplayAlerts = True
    Worksheets.Add(before:=Sheets("CALCULATOR")).Name = "DATA"
    Columns("C:C").NumberFormat = "m/d/yyyy"
    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
End Sub
 
Upvote 0
Oh yes it works now sir!! Its a Quasar level help.

It works fine with changed number of files in the source folder as well.

If you have noticed in MASTER_CALCULATOR that aside DATA sheet I have other two sheets where actually I have hyperlinked data from DATA sheet to make my calculations. But now the hyperlinks are lost every time I run the code.

Irony is that when the code was not suiting quite rightly hyperlinks worked and now I have the perfect code but hyperlinks lost!

My formula are appearing with #REF!like:
Code: 
=COUNTIFS(#REF!$C2:$C4001,">="&R9,#REF!$C2:$C4001,"<="&R11)

A little more help please for a solution to this! And if possible I would prefer to have imported data with it's source formatting which I had using earlier codes.
 
Last edited:
Upvote 0
Try:
Code: 
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\"
    Application.DisplayAlerts = False
    Sheets("DATA").Delete
    Application.DisplayAlerts = True
    Worksheets.Add(before:=Sheets("CALCULATOR")).Name = "DATA"
    Columns("C:C").NumberFormat = "m/d/yyyy"
    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
                With wkbDest.Sheets("DATA").Cells(Rows.Count, "C").End(xlUp).Offset(1, 0)
                    .PasteSpecial xlPasteValues
                    .PasteSpecial xlPasteFormats
                End With
                .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
    wkbDest.Sheets("DATA").Range("B2").Resize(Range("D" & Rows.Count).End(xlUp).Row).Borders.LineStyle = xlContinuous
    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
    wkbDest.Sheets("DATA").Columns.AutoFit
    Sheets("CAREER FLG").Range("C4").FormulaArray = "=IF(SUMIF(DATA!$D$2:$D$4001,$B4,DATA!E$2:E$4001)=0,"""",SUMIF(DATA!$D$2:$D$4001,$B4,DATA!E$2:E$4001))"
    Sheets("CAREER FLG").Range("C4").AutoFill Destination:=Sheets("CAREER FLG").Range("C4:O4"), Type:=xlFillDefault
    Sheets("CAREER FLG").Range("C4:O4").AutoFill Destination:=Sheets("CAREER FLG").Range("C4:O23"), Type:=xlFillDefault
    Application.Calculation = xlCalculationAutomatic
    Application.ScreenUpdating = True
End Sub
 
Upvote 0
Just tried the code. Again no issues with DATA sheet. Plus the source data format is also retained nicely.

As I see the last hurdle is that this time formulas are incorporated in the code from CAREER FLG sheet. Hyperlinks for 3rd sheet are preserved but the range given in code disappears from the sheet. Pic below:

https://app.box.com/s/6rgg6lctrd9qxu3v8nwq0f6twbub9a6d

Besides I also have multiple formula in 2nd sheet ("CALCULATOR") as well.

You are the boss and if I may propose something as it occurred to me:

May be the hyperlinks are lost as "DATA" sheet is deleted first and then recreated. If something can be done so that the previous data in "DATA" sheets are replaced with imported data without having to delete the entire sheet may be the hyperlinks could be retained without even mentioning inside the code. Again, you are the one who knows better if it is at all feasible.
 
Last edited:
Upvote 0
Could you explain what you are trying to do with this formula in the CALCULATOR sheet?
Code: 
=IF(IFERROR(INDEX(DATA!C$2:C$4001,SMALL(IF(DATA!$C$2:$C$4001>=$R$9,IF(DATA!$C$2:$C$4001<=$R$11,ROW(DATA!$C$2:$C$4001)-ROW(DATA!$C$2)+1)),ROWS(R$9:R9))),"")=0,"",IFERROR(INDEX(DATA!C$2:C$4001,SMALL(IF(DATA!$C$2:$C$4001>=$R$9,IF(DATA!$C$2:$C$4001<=$R$11,ROW(DATA!$C$2:$C$4001)-ROW(DATA!$C$2)+1)),ROWS(R$9:R9))),""))
 
Upvote 0
I am trying to list out entries between two specific dates (R9 & R11) using that formula.

In fact it was only meant to be:
Code: 
IFERROR(INDEX(DATA!C$2:C$4001,SMALL(IF(DATA!$C$2:$C$4001>=$R$9,IF(DATA!$C$2:$C$4001<=$R$11,ROW(DATA!$C$2:$C$4001)-ROW(DATA!$C$2)+1)),ROWS(R$9:R9))),"")

As I keep getting 0:00 in the fields where there is no data in the array C90:Q4089; to get rid of that I added an IF function:

IF(FORMULA=0,"",FORMULA)

Seemed to have served the purpose apparently.
 
Last edited:
Upvote 0
In CALCULATOR sheet apart from the array C90:Q4089 there is only one other formula that is hyperlinked to DATA sheet.

In R13 I used:
Code: 
=COUNTIFS(DATA!$C2:$C4001,">="&R9,DATA!$C2:$C4001,"<="&R11)
 
Upvote 0
You must log in or register to reply here.

Similar threads

Q
  • Question Question
Import multiple photos from folders in columns
Replies
2
Views
178
Qba
Q
G
  • Question Question
remove columns from multiple Excel-files in a folder
Replies
5
Views
217
gjvv
G
C
  • Solved
Extracting data with VBA macro button from files in designated folder
2 3
Replies
20
Views
899
Micron
M
L
  • Question Question
replace data for multiple sheets from source file to destination file based on back up(date,time)
Replies
1
Views
170
leap out
L
O
  • Question Question
VBA code to merge data from files into one master file
Replies
3
Views
468
jkpieterse
jkpieterse

Forum statistics

Threads
1,224,041
Messages
6,176,029
Members
452,697
Latest member
CuriousSpreadsheet

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top