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

brocq_18

New Member
Joined
May 21, 2021
Messages
8
Office Version
  1. 2007
Platform
  1. Windows
I'm very new to vba. I found the below recent thread and vba but am not able to amend the vba accordingly.


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.


VBA Code:
        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
 

Excel Facts

How to fill five years of quarters?
Type 1Q-2023 in a cell. Grab the fill handle and drag down or right. After 4Q-2023, Excel will jump to 1Q-2024. Dash can be any character.

mumps

Well-known Member
Joined
Apr 11, 2012
Messages
10,646
Change the destination sheet name (in red) and the file path of the folder containing your files (in blue) to suit your needs.
Rich (BB code):
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

New Member
Joined
May 21, 2021
Messages
8
Office Version
  1. 2007
Platform
  1. Windows
Change the destination sheet name (in red) and the file path of the folder containing your files (in blue) to suit your needs.
Rich (BB code):
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"
 

brocq_18

New Member
Joined
May 21, 2021
Messages
8
Office Version
  1. 2007
Platform
  1. Windows

ADVERTISEMENT

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. :cry:

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

New Member
Joined
May 21, 2021
Messages
8
Office Version
  1. 2007
Platform
  1. Windows
Oops!!! Delete
VBA Code:
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

Well-known Member
Joined
Apr 11, 2012
Messages
10,646

ADVERTISEMENT

My pleasure. :)
 

brocq_18

New Member
Joined
May 21, 2021
Messages
8
Office Version
  1. 2007
Platform
  1. Windows
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
 

brocq_18

New Member
Joined
May 21, 2021
Messages
8
Office Version
  1. 2007
Platform
  1. Windows
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"?

VBA Code:
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
 

Forum statistics

Threads
1,147,821
Messages
5,743,393
Members
423,792
Latest member
travisds

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
Top