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!

 

[mumps]

Is this any better? Give it a chance to run.

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
                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
    With 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))"
        .Range("C4").AutoFill Destination:=Sheets("CAREER FLG").Range("C4:O4"), Type:=xlFillDefault
        .Range("C4:O4").AutoFill Destination:=Sheets("CAREER FLG").Range("C4:O23"), Type:=xlFillDefault
        .Range("B4").FormulaArray = "=IFERROR(INDEX(DATA!$D$2:$D$4001,SMALL(IF((COUNTIF(B$3:B3,DATA!$D$2:$D$4001)=0)*(DATA!$D$2:$D$4001<>0),ROW(DATA!$D$2:$D$4001),""""),1)-ROW(DATA!$D$2)+1),"""")"
        .Range("B4").AutoFill Destination:=.Range("B4:B23"), Type:=xlFillDefault
    End With
    With Sheets("CALCULATOR")
        .Range("C90").FormulaArray = "=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:$R$9))),"""")"
        .Range("C90").AutoFill Destination:=.Range("C90:Q90"), Type:=xlFillDefault
        .Range("C90:Q90").AutoFill Destination:=.Range("C90:Q4089"), Type:=xlFillDefault
    End With
    Application.Calculation = xlCalculationAutomatic
    Application.ScreenUpdating = True
End Sub

 

[masud8956]

Sorry sir!

I gave it about 8-10 minutes to run but it seems to be stuck.

 

[lcaindoy]

Place this macro in a regular module in your destination workbook. It assumes this workbook contains a sheet named "MASTER". Save the workbook as a macro-enabled file.

Sub CopyRange()
    Application.ScreenUpdating = False
    Dim lastRow As Long
    Dim wkbDest As Workbook
    Dim wkbSource As Workbook
    Set wkbDest = ThisWorkbook
    Const strPath As String = "C:\Desktop\Yearly Data\"
    ChDir strPath
    strExtension = Dir(strPath & "*.xlsx")
    Do While strExtension <> ""
        Set wkbSource = Workbooks.Open(strPath & strExtension)
        With wkbSource
            .Sheets("Summary of the Year").Range("F78:U797").Copy wkbDest.Sheets("MASTER").Cells(Rows.Count, "B").End(xlUp).Offset(1, 0)
            .Close savechanges:=False
        End With
        strExtension = Dir
    Loop
    lastRow = wkbDest.Worksheets("MASTER").Cells(Rows.Count, "C").End(xlUp).Row
    wkbDest.Worksheets("MASTER").Sort.SortFields.Clear
    wkbDest.Worksheets("MASTER").Sort.SortFields.Add Key:=Range("C27:C" & lastRow) _
        , SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:=xlSortNormal
    With wkbDest.Worksheets("MASTER").Sort
        .SetRange Range("B26:Q" & lastRow)
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
    Application.ScreenUpdating = True
End Sub

Hi, I think this is also what I'm looking for. Can I use this code but could you please modify it with no range but I want to copy all the data

 

[mumps]

@Icaindoy: Welcome to the Forum. It is against Forum rules to post your question in another member's thread. Please start your own new thread and include a detailed explanation of what you want to do. You can include a link to this thread if you feel it would be helpful. Please have a look at the Forum rules at this link: https://www.mrexcel.com/forum/board-announcements/99490-forum-rules.html
@masud8956: What is causing all the problems is the fact that we have to either delete the "DATA" sheet and then re-create it or clear its contents. When we do either of these if causes the #REF errors in your formulas because the references in the formulas are deleted either way. This means that the formulas have to be re-inserted in the appropriate ranges by the macro. The only other alternative I know of is to eliminate the formulas entirely and have the macro perform the equivalent tasks. I will have a look at that possibility when I get some time but I can't promise a solution. Formulas are not my strong point.

 

[masud8956]

@mumps,

Now I am writing the 65th post of this thread! Tells only one thing: you are an extremely patient person. I really can't thank you enough for being such a nice guy and all your sincere efforts!!

I have been trying to get this done 4 months now. Out of desperation I kept trying in other forums. As I was new I did not know about the regulation of cross post. But then some moderator educated me. In ExcelForum I tried through following link:

https://www.excelforum.com/excel-programming-vba-macros/1223666-need-vba-for-importing-data-from-multiple-wordbooks-to-one-sheet-of-a-new-wordbook.html#post4915556

Yesterday I accidentally tried a code which I couldn't make work 3/4 months back. I don't know how but it worked! I just recorded 3/4 line macro and added it for "clear contents" as a prefix to that code. Only problem remains with that code is that blank rows are not eliminated like your code did. I left questions but no one seems to be interested to reply.

Its quite a small code. If you kindly look at the code and modify just enough only to eliminate blank rows I think that will be more than enough for me.

Sub Test()'
' Macro1 Macro
'


'
    Cells.Select
    Selection.ClearContents
    Range("I7").Select


    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
End Sub

 

[mumps]

Try putting this part of my code after the loop in the macro you posted:

Dim lastRow as long
lastRow = sheets("DATA").Cells(Rows.Count, "D").End(xlUp).Row
Sheets("DATA").Range("B1:Q" & lastRow).AutoFilter Field:=3, Criteria1:="="
Sheets("DATA").Range("B2:Q" & lastRow).SpecialCells(xlCellTypeVisible).EntireRow.Delete
If Sheets("DATA").AutoFilterMode Then Sheets("DATA").AutoFilterMode = False

To help speed up the macro, I would also put all of the code between these lines of code:

Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
'your code here
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic

 

[masud8956]

My bad I did not mention that with this new code I have used range G77:U796 instead of F77:U796. I got rid of the "Ser no" column and headers. Paste destination applied from A1. Thereby I still get the row numbers simply from the leftmost excel ribbon. Link of the end result at the end.

I tried your modification but does not work. May be the range in my code #65 and your suggestion are conflicting.
Range in my code

[COLOR=#333333]Do While fn <> ""
[/COLOR][COLOR=#333333]        With Sheets("Data").Range("a" & Rows.Count).End(xlUp)(1).Resize(n, t)[/COLOR]

and in your one #66

[COLOR=#333333]Sheets("DATA").Range("B1:Q" & lastRow).AutoFilter Field:=3, Criteria1:="="
[/COLOR][COLOR=#333333]Sheets("DATA").Range("B2:Q" & lastRow).SpecialCells(xlCellTypeVisible).EntireRow.Delete[/COLOR]

Do you see any problem here? If there is a problem I 'm sure I cannot fix it by myself.

The latest master file below with my code:
https://www.dropbox.com/s/ov270pnxg6h41z1/MASTER_CALCULATOR.xlsm?dl=0

 

[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)(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:="="
    Sheets("DATA").Range("A" & firstRow & ":A" & LastRow).SpecialCells(xlCellTypeVisible).EntireRow.Delete
    If Sheets("DATA").AutoFilterMode Then Sheets("DATA").AutoFilterMode = False
    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic
End Sub

 

[masud8956]

Thanks a lot! It takes quite long though....but works fine. I guess it because of the large arrays being imported.

 

[mumps]

You are very welcome.