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
 

mumps

Well-known Member
Joined
Apr 11, 2012
Messages
10,624
Try:
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("*.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
 

Excel Facts

What does custom number format of ;;; mean?
Three semi-colons will hide the value in the cell. Although most people use white font instead.

Forum statistics

Threads
1,141,063
Messages
5,704,064
Members
421,326
Latest member
pfaustino

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