[Macro] [VBA] More than One Reference Workbooks to copy cells to a One Workbook / Macro

[ozan efendi]

Hi, i have Book1 (reference workbook) and Book2 (where i copy values from Book1)

Now i have i macro which helps me to fetch the datas and paste the values in the format below.

But i can only doing this for one reference workbooks. But i need to add more reference workbooks in a file and paste to Book2. (etc: Book1, Book3, Book4, ....... to Book2)

Book2 looks like:

A1 B1 C1 D1

Name Adress Age Sex

Ozan xxxxxx 27 M

Here' s the Code.

Regards,

Ozan.

Option Explicit


Sub TransferData()
Dim wkb As Workbook, wks As Worksheet, LastRow As Long
Dim FilePath As String, FileName As String
Dim ws As Worksheet, blnOpened As Boolean
'Change these variables as desired...
FilePath = "C:\Users\ozzy\Desktop\vba\" 'this is my path
' FilePath = "C:\YourFullFilePathHere\" 'change path here
FileName = "Book2.xlsm" 'change name here
Call ToggleEvents(False)
Set ws = Workbooks.Open(FilePath & "Book1.xlsx").Sheets("Sheet1")
'Set ws = Workbooks.Open(FilePath & "Book1.xlsx").Sheets("Sheet1") 'change source sheet name here
If WbOpen(FileName) = True Then
Set wkb = Workbooks(FileName)
blnOpened = False
Else
If Right(FilePath, 1) <> Application.PathSeparator Then
FilePath = FilePath & Application.PathSeparator
End If
Set wkb = Workbooks(FilePath & "Book1.xlsx")
blnOpened = True
End If
Set wks = wkb.Sheets("Sheet1") 'change destination sheet name here
LastRow = wks.Cells.Find(what:="*", after:=wks.Cells(1, 1), searchorder:=xlByRows, searchdirection:=xlPrevious).Row + 1
wks.Cells(LastRow, "A").Value = ws.Cells(1, "B").Value
wks.Cells(LastRow, "B").Value = ws.Cells(4, "B").Value
wks.Cells(LastRow, "C").Value = ws.Cells(7, "B").Value
wks.Cells(LastRow, "D").Value = ws.Cells(7, "E").Value
If blnOpened = True Then
wkb.Close SaveChanges:=True
End If
Call ToggleEvents(True)
End Sub






Sub ToggleEvents(blnState As Boolean)
'Originally written by firefytr
With Application
.DisplayAlerts = blnState
.EnableEvents = blnState
.ScreenUpdating = blnState
If blnState Then .CutCopyMode = False
If blnState Then .StatusBar = False
End With
End Sub


Function WbOpen(wbName As String) As Boolean
'Originally found written by Jake Marx
On Error Resume Next
WbOpen = Len(Workbooks(wbName).Name)
End Function

 

[Peter_SSs]

Deleted

 

[kafa1500]

i have the same problem, can anybody help on this please?

 

[kafa1500]

.