vba-to-copy-data and filename-from-multiple-workbooks

[brocq_18]

I'm very new to vba. I found the below recent thread and vba but am not able to amend the vba accordingly.

VBA to copy data from multiple workbooks into master sheet

I had an extra space in one of the lines. Try: Sub CopyRange() Application.ScreenUpdating = False Dim wkbDest As Workbook Dim wkbSource As Workbook Set wkbDest = ThisWorkbook Dim LastRow As Long Const strPath As String = "C:\Users\xbv\Desktop\group1\" ChDir strPath...

www.mrexcel.com

I have 700 files which are all named ABC 00123456.
Within each file are three tabs, the 2nd tab, "Pikachu", contains a 6 digit value in cell Q2.

I just want to extract the filename and it's corresponding value from "Pikachu" and cell Q2. Output can be any form.

Any help would be greatly appreciated.

        Sub CopyRange()
Application.ScreenUpdating = False
Dim wkbsource As Workbook, wsDest As Worksheet, LastRow As Long
Set wsDest = ThisWorkbook.Sheets("Master")
Const strPath As String = "C:\Users\xbv\Desktop\group1\"
    ChDir strPath
strExtension = Dir("*.xlsm")
Do While strExtension <> ""
Set wkbsource = Workbooks.Open(strPath & strExtension)
If Not IsError(Evaluate("=ISREF('[" & wkbsource.Name & "]" & "Data" & "'!$A$1)")) Then
With wkbsource.Sheets("Data")
LastRow = .Range("D" & Rows.Count).End(xlUp).Row
.Range("D3:I" & LastRow).Copy
With wsDest
.Cells(.Rows.Count, "D").End(xlUp).Offset(1, 0).PasteSpecial xlPasteValues
.Cells(.Rows.Count, "A").End(xlUp).Offset(1, 0).Resize(LastRow - 2) = wkbsource.Name
If Not IsError(Evaluate("=ISREF('[" & wkbsource.Name & "]" & "Info" & "'!$A$1)")) Then
.Cells(.Rows.Count, "B").End(xlUp).Offset(1, 0).Resize(LastRow - 2).Value = wkbsource.Sheets("Info").Range("B2").Value
.Cells(.Rows.Count, "C").End(xlUp).Offset(1, 0).Resize(LastRow - 2).Value = wkbsource.Sheets("Info").Range("B3").Value
End If
End With
End With
ElseIf Not IsError(Evaluate("=ISREF('[" & wkbsource.Name & "]" & "Info" & "'!$A$1)")) Then
With wsDest
.Cells(.Rows.Count, "A").End(xlUp).Offset(1, 0).Resize(LastRow - 2) = wkbsource.Name
.Cells(.Rows.Count, "B").End(xlUp).Offset(1, 0).Resize(LastRow - 2).Value = wkbsource.Sheets("Info").Range("B2").Value
.Cells(.Rows.Count, "C").End(xlUp).Offset(1, 0).Resize(LastRow - 2).Value = wkbsource.Sheets("Info").Range("B3").Value
End With
End If
wkbsource.Close savechanges:=False
strExtension = Dir
Loop
Application.ScreenUpdating = True
End Sub

 

[mumps]

Try:

Sub CopyRange()
    Application.ScreenUpdating = False
    Dim wkbsource As Workbook, wsDest As Worksheet, LastRow As Long
    Set wsDest = ThisWorkbook.Sheets("Master")
    Const strPath As String = "C:\Users\xbv\Desktop\group1\"
    ChDir strPath
    strExtension = Dir("*.xls*")
    Do While strExtension <> ""
        Set wkbsource = Workbooks.Open(strPath & strExtension)
        With wsDest
            LastRow = .Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row + 1
            .Range("A" & LastRow) = wkbsource.Name
            .Range("B" & LastRow) = Sheets("Pikachu").Range("Q2").Value
        End With
        End If
        wkbsource.Close savechanges:=False
        strExtension = Dir
    Loop
    Application.ScreenUpdating = True
End Sub