Copy and Past the Data from Multiple Closed Workbooks

T

thespardian

Board Regular
Joined
Aug 31, 2012
Messages
119
Office Version
  1. 2016
  2. 2013
Platform
  1. Windows
Hi there!
I am seeking help on the following matter: -

I have multiple workbooks, with 05 worksheets, in folder “NewFolder” on the desktop.
The format of Sheets is same in all workbooks.
I after a VBA code which would do the following tasks in a separate workbook called Summery.xlsm

Task 1
Copy all data of Sheet D from Workbook1->and paste it to Sheet1of Summery
Copy all data of Sheet D from Workbook 2->and paste it to Sheet1of Summery
Copy all data of Sheet D from Workbook 3->and paste it to Sheet1of Summery
And so on till last workbook

Task2
Copy all data of Sheet A from Workbook1->and paste it to Sheet2of Summery
Copy all data of Sheet A from Workbook2->and paste it to Sheet2of Summery
Copy all data of Sheet A from Workbook3->and paste it to Sheet2of Summery
And so on till last workbook

Any help on the matter will be highly appreciated.

Links of the workbooks are given below, please
Summery
Book1
Book2
 
Sort by date Sort by votes
thespardian said:
I followed your instructions. The codes doesn't show any error. But nothing happened. Just a blank workbook opened. The picture of which is as under
Click to expand...
this happened because you placed Summery workbook in same folder with 2 target files, when macro open file in selected folder, it will open summery workbook and close it after done, so i change code like this:
VBA Code: 
Sub MergeData()
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    Dim sFiles As Variant
    Dim wb As Workbook, ws As Worksheet
    Dim i As Long, j As Long, Fnum As Integer
    sFiles = Application.GetOpenFilename(Filefilter:="Excel File (*.xls*),*xlsx*", MultiSelect:=True)
    If VarType(sFiles) = vbBoolean Then Exit Sub
    For Fnum = LBound(sFiles) To UBound(sFiles)
        Set wb = Workbooks.Open(sFiles(Fnum))
        For Each ws In wb.Sheets
            If ws.Name = "A" Then
                If Not IsEmpty(ws.Range("B3")) Then
                    Debug.Print ws.Range("A3:O" & lr(ws, 1)).Address
                    ws.Range("A3:O" & lr(ws, 1)).Copy Destination:=ThisWorkbook.Sheets(2).Range("A" & lr(ThisWorkbook.Sheets(2), 1) + 1)
                End If
            ElseIf ws.Name = "D" Then
                If Not IsEmpty(ws.Range("A6")) Or Not IsEmpty("J6") Then
                    If lr(ws, 2) > lr(ws, 10) Then
                        i = lr(ws, 2)
                    Else
                        i = lr(ws, 10)
                    End If
                    If lr(ThisWorkbook.Sheets(1), 1) > lr(ThisWorkbook.Sheets(1), 9) Then 'change this
                        j = lr(ThisWorkbook.Sheets(1), 1)
                    Else
                        j = lr(ThisWorkbook.Sheets(1), 9)
                    End If
                    ws.Range("B6:Q" & i).Copy Destination:=ThisWorkbook.Sheets(1).Range("A" & j + 1)
                End If
            End If
        Next ws
        wb.Close (False)
    Next Fnum
    MsgBox "Completed"
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
End Sub
with this code, you need run code and select all files that need to get data from but don't select summery workbook if that workbook in same folder with those files
 
Upvote 0

Excel Facts

How can you turn a range sideways?
Copy the range. Select a blank cell. Right-click, Paste Special, then choose Transpose.
I am really thankful for the patience and kind guidance. The codes are working very well except one thing.

The “Sheet2” of the “Summery” have many blank rows. In the given example, the data has been successfully copied from Book1 and Book2 but pasted in Summery.Sheet2. range(A1:O13 and A200:O207). The problem is ---Row14 to Row 199 are blank.

IMHO, it is (not sure about it due to my poor knowledge)
VBA Code: 
lr = ws.Cells(Rows.Count, col).End(xlUp).Row
And i am trying to solve it my self since because i have bothered you a lot. but no luck

Is it possible to have the continues data. I mean no blank rows.

TIA
 
Upvote 0
Power Query alternative: Get Data --> From File --> From Folder. Once for each of the two sheets.
 
Upvote 0
thespardian said:
I am really thankful for the patience and kind guidance. The codes are working very well except one thing.

The “Sheet2” of the “Summery” have many blank rows. In the given example, the data has been successfully copied from Book1 and Book2 but pasted in Summery.Sheet2. range(A1:O13 and A200:O207). The problem is ---Row14 to Row 199 are blank.

IMHO, it is (not sure about it due to my poor knowledge)
VBA Code: 
lr = ws.Cells(Rows.Count, col).End(xlUp).Row
And i am trying to solve it my self since because i have bothered you a lot. but no luck

Is it possible to have the continues data. I mean no blank rows.

TIA
Click to expand...
try this:
VBA Code: 
Sub MergeData()
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    Dim sFiles As Variant
    Dim wb As Workbook, ws As Worksheet
    Dim i As Long, j As Long, Fnum As Integer
    sFiles = Application.GetOpenFilename(Filefilter:="Excel File (*.xls*),*xlsx*", MultiSelect:=True)
    If VarType(sFiles) = vbBoolean Then Exit Sub
    For Fnum = LBound(sFiles) To UBound(sFiles)
        Set wb = Workbooks.Open(sFiles(Fnum))
        For Each ws In wb.Sheets
            If ws.Name = "A" Then
                If Not IsEmpty(ws.Range("B3")) Then
                    ws.Range("A3:O" & lr(ws, 2)).Copy Destination:=ThisWorkbook.Sheets(2).Range("A" & lr(ThisWorkbook.Sheets(2), 2) + 1) 'change this to find last row of sheet A, column 2 because column 1 contains formula
                End If
            ElseIf ws.Name = "D" Then
                If Not IsEmpty(ws.Range("A6")) Or Not IsEmpty("J6") Then
                    If lr(ws, 2) > lr(ws, 10) Then
                        i = lr(ws, 2)
                    Else
                        i = lr(ws, 10)
                    End If
                    If lr(ThisWorkbook.Sheets(1), 1) > lr(ThisWorkbook.Sheets(1), 9) Then
                        j = lr(ThisWorkbook.Sheets(1), 1)
                    Else
                        j = lr(ThisWorkbook.Sheets(1), 9)
                    End If
                    ws.Range("B6:Q" & i).Copy Destination:=ThisWorkbook.Sheets(1).Range("A" & j + 1)
                End If
            End If
        Next ws
        wb.Close (False)
    Next Fnum
    MsgBox "Completed"
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
End Sub
 
Upvote 0
Solution
Thanks a ton! Its really a blessing for me. I really appreciate your patience. I just deleted/copy paste some lines and its working.

VBA Code: 
Sub MergeData()
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    Dim sFiles As Variant
    Dim wb As Workbook, ws As Worksheet
    Dim i As Long, j As Long, Fnum As Integer
    sFiles = Application.GetOpenFilename(Filefilter:="Excel File (*.xls*),*xlsx*", MultiSelect:=True)
    If VarType(sFiles) = vbBoolean Then Exit Sub
    For Fnum = LBound(sFiles) To UBound(sFiles)
        Set wb = Workbooks.Open(sFiles(Fnum))
        For Each ws In wb.Sheets
            If ws.Name = "A" Then
                If Not IsEmpty(ws.Range("B3")) Then
                    ws.Range("A3:O" & lr(ws, 2)).Copy Destination:=ThisWorkbook.Sheets(2).Range("A" & lr(ThisWorkbook.Sheets(2), 2) + 1) 'change this to find last row of sheet A, column 2 because column 1 contains formula
                End If
           
           ElseIf ws.Name = "D" Then
                If Not IsEmpty(ws.Range("B6")) Then
                    ws.Range("B5:I" & lr(ws, 2)).Copy Destination:=ThisWorkbook.Sheets(1).Range("A" & lr(ThisWorkbook.Sheets(1), 2) + 1) 'change this to find last row of sheet A, column 2 because column 1 contains formula
                End If
                If Not IsEmpty(ws.Range("J6")) Then
                    ws.Range("J5:P" & lr1(ws, 2)).Copy Destination:=ThisWorkbook.Sheets(1).Range("J" & lr1(ThisWorkbook.Sheets(1), 2) + 1) 'change this to find last row of sheet A, column 2 because column 1 contains formula
                End If
                            
               
            End If
        Next ws
        wb.Close (False)
    Next Fnum
    MsgBox "Completed"
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
End Sub

Private Function lr(ByVal ws As Worksheet, ByVal col As Integer) As Long
    lr = ws.Cells(Rows.Count, "B").End(xlUp).Row
     
End Function
Private Function lr1(ByVal ws As Worksheet, ByVal col As Integer) As Long
  
    lr1 = ws.Cells(Rows.Count, "J").End(xlUp).Row
   
End Function
 
Upvote 0
thespardian said:
Thanks a ton! Its really a blessing for me. I really appreciate your patience. I just deleted/copy paste some lines and its working.

VBA Code: 
Sub MergeData()
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    Dim sFiles As Variant
    Dim wb As Workbook, ws As Worksheet
    Dim i As Long, j As Long, Fnum As Integer
    sFiles = Application.GetOpenFilename(Filefilter:="Excel File (*.xls*),*xlsx*", MultiSelect:=True)
    If VarType(sFiles) = vbBoolean Then Exit Sub
    For Fnum = LBound(sFiles) To UBound(sFiles)
        Set wb = Workbooks.Open(sFiles(Fnum))
        For Each ws In wb.Sheets
            If ws.Name = "A" Then
                If Not IsEmpty(ws.Range("B3")) Then
                    ws.Range("A3:O" & lr(ws, 2)).Copy Destination:=ThisWorkbook.Sheets(2).Range("A" & lr(ThisWorkbook.Sheets(2), 2) + 1) 'change this to find last row of sheet A, column 2 because column 1 contains formula
                End If
          
           ElseIf ws.Name = "D" Then
                If Not IsEmpty(ws.Range("B6")) Then
                    ws.Range("B5:I" & lr(ws, 2)).Copy Destination:=ThisWorkbook.Sheets(1).Range("A" & lr(ThisWorkbook.Sheets(1), 2) + 1) 'change this to find last row of sheet A, column 2 because column 1 contains formula
                End If
                If Not IsEmpty(ws.Range("J6")) Then
                    ws.Range("J5:P" & lr1(ws, 2)).Copy Destination:=ThisWorkbook.Sheets(1).Range("J" & lr1(ThisWorkbook.Sheets(1), 2) + 1) 'change this to find last row of sheet A, column 2 because column 1 contains formula
                End If
                           
              
            End If
        Next ws
        wb.Close (False)
    Next Fnum
    MsgBox "Completed"
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
End Sub

Private Function lr(ByVal ws As Worksheet, ByVal col As Integer) As Long
    lr = ws.Cells(Rows.Count, "B").End(xlUp).Row
    
End Function
Private Function lr1(ByVal ws As Worksheet, ByVal col As Integer) As Long
 
    lr1 = ws.Cells(Rows.Count, "J").End(xlUp).Row
  
End Function
Click to expand...
just need 1 last row function bro, the "col" variable in my "lr" function is column number, if you need to find last row of column B, just change [ lr("your worksheet",2) ], if you need to find last row of column J, just change [ lr("your worksheet",10) ]
 
Upvote 0
eiloken said:
just need 1 last row function bro, the "col" variable in my "lr" function is column number, if you need to find last row of column B, just change [ lr("your worksheet",2) ], if you need to find last row of column J, just change [ lr("your worksheet",10) ]
Click to expand...
Thanks for the input. Now i am able to understand the meaning of 2 and 10.
My bad, i could not explain my problem properly. Although i tried my best to expain it in the notes inserted in the Book 1 and Book 2.
Let me explain it again.
If the data under column B > data under column J Then
lr("your worksheet",2
Click to expand...
If the data under column B < data under column J Then
lr("your worksheet",10
Click to expand...
You gave me the strength of knowledge with kindness and patience. For which i am really thankful to you from the bottom of my heart.
 
Upvote 0
You must log in or register to reply here.

Similar threads

T
  • Question
Data Extraction from different workbooks in a folder
Replies
2
Views
316
thespardian
T
A
  • Question
Copy & Paste from workbook to another with criterias
Replies
2
Views
144
Anthony86
A
L
  • Question
Copy Subtotals from Source Workbook to Current Workbook
Replies
1
Views
250
DanteAmor
DanteAmor
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
247
Insurance Dave
I
GMC The Macro Man
  • Solved
VBA Script - Return to named file
Replies
6
Views
127
mumps
mumps

Forum statistics

Threads
1,215,071
Messages
6,122,964
Members
449,094
Latest member
Anshu121

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