VBA Code to Copy data from Multiple Excel workbooks, without opening them, and Paste it into Master Excel workbook.

[Reetesh]

Hello Everyone,

I was trying to come up with a VBA code which copies data from the last two rows of multiple workbooks in a folder, without out opening them, and pastes it into a master workbook.

After googling for it a lot, I got a VBA code mentioned below:


'credit for this technique goes to John Walkenback
'17 MVP tips, tricks and shortcuts for Excel » The Spreadsheet Page

Sub GetDataDemo()

Dim FilePath$, Row&, Column&, Address$

'change constants & FilePath below to suit
'***************************************
Const FileName$ = "Book1.xls"
Const SheetName$ = "Sheet1"
Const NumRows& = 10
Const NumColumns& = 10
FilePath = ActiveWorkbook.Path & "\"
'***************************************

DoEvents
Application.ScreenUpdating = False
If Dir(FilePath & FileName) = Empty Then
MsgBox "The file " & FileName & " was not found", , "File Doesn't Exist"
Exit Sub
End If
For Row = 1 To NumRows
For Column = 1 To NumColumns
Address = Cells(Row, Column).Address
Cells(Row, Column) = GetData(FilePath, FileName, SheetName, Address)
Columns.AutoFit
Next Column
Next Row
ActiveWindow.DisplayZeros = False
End Sub

Private Function GetData(Path, File, Sheet, Address)
Dim Data$
Data = "'" & Path & "[" & File & "]" & Sheet & "'!" & _
Range(Address).Range("A1").Address(, , xlR1C1)
GetData = ExecuteExcel4Macro(Data)
End Function

However this code only copies the data from First 10 rows & first 10 columns of one workbook.
I tried to amend the above mentioned code. However, I've been unsuccessful in getting the result that I want.

I want to copy the data from last two rows of all the workbooks present in a folder, without opening those workbooks, and paste it in a master file. In the Master file the data which is supposed to be pasted, should be pasted at the top, after inserting a row, below the header(First Row is the Header).

The above code copies and pastes the data without opening the workbook. However, it does it only for one workbook and copies the data from first 10 rows & first 10 columns.

Any Help is appreciated.

Thanks in Advance

Thanks in advance

 

[NdNoviceHlp]

Hi Reetesh. Couple of questions.... is the master wb in the same folder as all the other wbs; what is the sheet name(s) where the data is located; what is the sheet name in the master wb where the import data goes? Dave

 

[Reetesh]

Hi Reetesh. Couple of questions.... is the master wb in the same folder as all the other wbs; what is the sheet name(s) where the data is located; what is the sheet name in the master wb where the import data goes? Dave

Hello Dave,

The master file will be in a different folder & the worksheet's name where the data needs to be pasted or imported is "Data".

There are 2 worksheets in all the workbooks, for now the worksheet from where I want to copy the data, I've kept the name as "Sheet2" and this is same for all the workbooks in the folder.

 

[NdNoviceHlp]

If the master is in a different folder then what is the full path of the folder with the data files? Dave

 

[Reetesh]

Hi Dave,
Below is the path on my system where the workbooks(not the master file) are:

"C:\Users\Jeevesh\Desktop\Dump\New folder\"

I hope you are asking for this, right??

 

[NdNoviceHlp]

Hi Reetesh. U can trial this code. It uses an array instead of copy/paste. Please save a copy of your wb before testing. Dave

Sub test()
Dim LastRow As Double, sht As Worksheet, FSO As Object
Dim FLdr As Object, FileNm As Object, Cnt As Integer
Dim Cnt2 As Integer, Cnt3 As Integer, Cnt4 As Integer
Dim RngArr() As Variant, Rng As Range, LastCol As Double
On Error GoTo Erfix
Application.Cursor = xlWait
Application.DisplayAlerts = False
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Cnt2 = 1 'dimension array
Cnt3 = 0 'array positions

Set FSO = CreateObject("scripting.filesystemobject")
'***change Folder path/name to your folder path/name
'Set FLdr = FSO.GetFolder(ThisWorkbook.Path & "\Datafiles")
Set FLdr = FSO.GetFolder("C:\Users\Jeevesh\Desktop\Dump\New folder")
For Each FileNm In FLdr.Files
If FileNm.Name Like "*.xlsm" Then
Workbooks.Open Filename:=FileNm
For Each sht In Workbooks(FileNm.Name).Sheets
If LCase(sht.Name) = LCase("Sheet2") Then
With Sheets("Sheet2")
LastRow = .Range("A" & .Rows.Count).End(xlUp).Row
LastCol = .Cells(LastRow, .Columns.Count).End(xlToLeft).Column
End With
Cnt2 = Cnt2 + 1
ReDim Preserve RngArr(Cnt2)
With Workbooks(FileNm.Name).Sheets(sht.Name)
Set Rng = .Range(.Cells(LastRow - 1, 1), .Cells(LastRow, LastCol))
End With
RngArr(Cnt3) = Rng
Cnt3 = Cnt3 + 1
Exit For
End If
Next sht
Workbooks(FileNm.Name).Close SaveChanges:=False
End If
Next FileNm

Cnt = 3
For Cnt4 = 0 To Cnt3 - 1
With ThisWorkbook.Sheets("Data")
.Range(.Cells(Cnt, "A"), .Cells(Cnt + 1, LastCol)) = RngArr(Cnt4)
End With
Cnt = Cnt + 2
Next Cnt4

Erfix:
If Err.Number <> 0 Then
On Error GoTo 0
MsgBox "Error"
End If
Application.DisplayAlerts = True
Application.ScreenUpdating = True
Application.Calculation = xlAutomatic
Application.Cursor = xlDefault
Set FLdr = Nothing
Set FSO = Nothing
End Sub

 

[Reetesh]

Hello Dave,
Thanks a lot.
The code works perfectly.
However, there is one thing that i wanted to ask. I may sound stupid in asking this as I'm fairly new to VBA?.
In the code which you sent, it first opens the workbooks in the folder and then copies the data.

Is there a way, where in the code copies the data from the workbooks without opening them, like the one which I pasted in the original post?

The reason why I do not want the workbooks to open is because there will be people who will be using these workbooks on a time to time basis. Because of that reason, if I use this code to collate the latest data(Data from the last 2 used rows), it may be possible that the code might give an error, because of workbooks being open at someone else's system.

I noticed that the VBA code which I pasted in my original post, in that the master file was in the same folder where the other workbook is. If it will help, I can keep the master file in the Same folder where all the other workbooks are.

Thanks in advance mate

 

[NdNoviceHlp]

I was going to respond that there is no way to get data from a wb without opening it but after googling ExecuteExcel4Macro, I'm not so sure. I really don't understand the ExecuteExcel4Macro as to whether or not the wb is being opened? Sorry, I really can't help with coding for ExecuteExcel4Macro as I don't understand it. It doesn't matter whether or not the master is in the same folder as the other wbs... just need to adjust the code for the file paths. HTH. Dave
ps. the code posted does not use the clipboard as there is no copy and pasting. It loads all the data as ranges to an array from all wbs and then unloads the array all at once to the master wb... much quicker and more stable.

 

[Reetesh]

Not a problem Dave
Thank you for all your help, much appreciated.?
Will keep on looking for a way for this, if I'll find any will update you on this thread.

 

[NdNoviceHlp]

You could just ignore the open wbs with a bit more code... not sure if this would help.

Function IsFileOpen(fileName As String) As Boolean
Dim fileNum As Integer
Dim errNum As Integer
'Allow all errors to happen
On Error Resume Next
fileNum = FreeFile()
'Try to open and close the file for input.
'Errors mean the file is already open
Open fileName For Input Lock Read As #fileNum
Close fileNum
If Err.Number <> 0 Then
On Error GoTo 0
IsFileOpen = True
End If
End Function

Adjust this part of the code for the open file check....

For Each FileNm In FLdr.Files
If FileNm.Name Like "*.xlsm" Then
If Not IsFileOpen(FileNm.Path) Then
Workbooks.Open fileName:=FileNm
For Each sht In Workbooks(FileNm.Name).Sheets
If LCase(sht.Name) = LCase("Sheet2") Then
With Sheets("Sheet2")
LastRow = .Range("A" & .Rows.Count).End(xlUp).Row
LastCol = .Cells(LastRow, .Columns.Count).End(xlToLeft).Column
End With
Cnt2 = Cnt2 + 1
ReDim Preserve RngArr(Cnt2)
With Workbooks(FileNm.Name).Sheets(sht.Name)
Set Rng = .Range(.Cells(LastRow - 1, 1), .Cells(LastRow, LastCol))
End With
RngArr(Cnt3) = Rng
Cnt3 = Cnt3 + 1
Exit For
End If
Next sht
Workbooks(FileNm.Name).Close SaveChanges:=False
End If
End If
Next FileNm

Untested but seems like it should work. Dave