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]

Change the destination sheet name (in red) and the file path of the folder containing your files (in blue) to suit your needs.

Sub CopyRange()
    Application.ScreenUpdating = False
    Dim wkbsource As Workbook, wsDest As Worksheet
    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
            .Cells(.Rows.Count, "A").End(xlUp).Offset(1, 0) = wkbsource.Name
            .Cells(.Rows.Count, "B").End(xlUp).Offset(1, 0) = Sheets("Pikachu").Range("Q2").Value
        End With
        End If
        wkbsource.Close savechanges:=False
        strExtension = Dir
    Loop
    Application.ScreenUpdating = True
End Sub

 

[brocq_18]

Change the destination sheet name (in red) and the file path of the folder containing your files (in blue) to suit your needs.

Sub CopyRange()
    Application.ScreenUpdating = False
    Dim wkbsource As Workbook, wsDest As Worksheet
    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
            .Cells(.Rows.Count, "A").End(xlUp).Offset(1, 0) = wkbsource.Name
            .Cells(.Rows.Count, "B").End(xlUp).Offset(1, 0) = Sheets("Pikachu").Range("Q2").Value
        End With
        End If
        wkbsource.Close savechanges:=False
        strExtension = Dir
    Loop
    Application.ScreenUpdating = True
End Sub

Thanks for your quick response Mumps, I get "Compile error End If without block if"

 

[mumps]

Oops!!! Delete

End If

 

[brocq_18]

So I removed the End If, then got a runtime error 9 subscript out of range message.

If I select debug it highlights "Set wsDest = ThisWorkbook.Sheets("Master")".

I changed this to "Set wsDest = ThisWorkbook.Sheets("sheet 1")" to match the name of the current sheet and it ran but no data was present.

Just to be clear, I have a folder with 700 files with names of the form "ABC 00123456" and I need to extract the value found in cell Q2 in sheet "Pikachu",

 

[brocq_18]

Oops!!! Delete

End If

Ignore my previous message, it's working now, well it did it for 233 files for some reason then stopped...I'll rerun and see what I get. Thanks!

 

[mumps]

My pleasure.

 

[brocq_18]

My pleasure.

Hi wondering if you can assist again, is there a way to have it skip any files which have issues opening.

Basically I have been given an updated list of the "ABC 00123456" files and some of them have warning when opening and this causes the script to pause.

Thanks

 

[mumps]

What kind of warnings?

 

[brocq_18]

I've sorted that problem thanks, I have another though now.
When extracting the relevant cell data, if there is no data present the cell is left empty, as desired, however the following data gets populated into this previous empty cell.
Is the following appropriate to avoid this and have the empty cell populated with "Empty"?

Sub CopyRange()
    Application.ScreenUpdating = False
    Dim wkbsource As Workbook, wsDest As Worksheet
    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
            .Cells(.Rows.Count, "A").End(xlUp).Offset(1, 0) = wkbsource.Name
            .Cells(.Rows.Count, "B").End(xlUp).Offset(1, 0) = Sheets("Pikachu").Range("Q2").Value
            If IsEmpty(cell) Then
                cell.Value = "Empty"
        End With
        End If
        wkbsource.Close savechanges:=False
        strExtension = Dir
    Loop
    Application.ScreenUpdating = True
End Sub