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
Tried the code.

getting a run time error "Path not found"
After debugging line 11 is highlighted containing text ChDir strPath
 
Upvote 0

Excel Facts

What is the fastest way to copy a formula?
If A2:A50000 contain data. Enter a formula in B2. Select B2. Double-click the Fill Handle and Excel will shoot the formula down to B50000.
My apologies. I forgot to take out my test folder path. Try this version.
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\"
    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("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
 
Upvote 0
Great that this time the list was generated exactly the way I want it. I guess your code allows the list to get rid of blank rows.

Just a little problem:

.Dates are perfectly listed upto row 1840. For some reason the rest of the data are not in line with the date. As I understand since my last row should be 1840 but it has imported way more than that?
 
Upvote 0
The code copies the entire range including the blank rows as you requested. I'm not sure what you mean by
Dates are perfectly listed upto row 1840. For some reason the rest of the data are not in line with the date. As I understand since my last row should be 1840 but it has imported way more than that?
Click to expand...
 
Upvote 0
Sorry for #33

Great that this time the list was generated exactly the way I want it. I guess your code allows the list to get rid of blank rows. I am sorry I did not make it clear that I want to get rid of the blank rows.

Just a little problem:

1. Dates are perfectly listed upto row 1840. For some reason the rest of the data are not in line with the date. There are lot many rows after that and the process kind of repeats itself except the date. As I understand my last row should be 1840 but it has imported way more than that.
You will understand what I mean if you kindly look at the link

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


Sorry to say you this now, Instead of importing F76:U76 may be G76:U76 would be better. That way I get rid of the "SER NO" column at Column B (In my source files they are numbered from 1 to 720 and thus the same pattern appears in DATA sheet). I still want the Ser No to be generated automatically at Column B in chronological order upto the last row that contains data and range G76:U76 on the right side of that exactly where it is now.

Is that possible. I know I have given you a lot of trouble but it seems with a very few step I can reach home with your help.
 
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\"
    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("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
Sorry!

getting a run time error "Path not found"
After debugging line 11 is highlighted containing text ChDir strPath
 
Upvote 0
same problem as before. I think I'm "losing it"!!!! 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\"
    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
End Sub
 
Upvote 0
WoW! Perfect sir! Hats off to you!

Had I been in your place and someone like "ME" bugging so many times,,,would have lost it long before. :)

Can't thank you enough!!!
 
Upvote 0
You are very welcome. :) Glad it worked out.
 
Upvote 0
You must log in or register to reply here.

Similar threads

A
  • Question
How can I use VBA to automate the process of importing data from multiple Excel files into a consolidated worksheet?
Replies
3
Views
538
Fluff
Fluff
G
  • Solved
Change Macro to import files from hyperlinks
2
Replies
12
Views
447
GarnesGambit
G
I
  • Question
VBA - Copy Sheet from a workbook saved as a date - paste to specifically named sheet in another workbook based on the date
Replies
2
Views
268
Insurance Dave
I
M
  • Question
Macro - Merge all files into one sheet
Replies
2
Views
291
MountainFog
M
S
  • Question
VBA Challenge
Replies
2
Views
256
SnowyBry
S

Forum statistics

Threads
1,215,218
Messages
6,123,676
Members
449,116
Latest member
HypnoFant

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