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

Highlight Duplicates
Home, Conditional Formatting, Highlight Cells, Duplicate records, OK to add pink formatting to any duplicates in selected range.
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

Q
  • Question Question
Import multiple photos from folders in columns
Replies
2
Views
157
Qba
Q
G
  • Question Question
remove columns from multiple Excel-files in a folder
Replies
5
Views
213
gjvv
G
C
  • Solved
Extracting data with VBA macro button from files in designated folder
2 3
Replies
20
Views
861
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
167
leap out
L
O
  • Question Question
VBA code to merge data from files into one master file
Replies
3
Views
467
jkpieterse
jkpieterse

Forum statistics

Threads
1,223,911
Messages
6,175,337
Members
452,637
Latest member
Ezio2866

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