Loop Through Multiple Workbooks/Sheets And Extract Values From Columns With Label

Here is my test sample

It worked after I changed this line of code:

Code:

---

Filename = Dir(Path & "*.xls*")

---

to:

Code:

---

Filename = Dir(Path & "*.xlsx")

---

My AllItems file previously had extension as xlsx instead of xlsm. Maybe that was the reason why it kept opening file that is already open.

mdmackillop and MINCUS1308, thank you so much for helping me with this macro. I am learning from the best.

Happy you got it sorted.

Hello All, i would like to copy the paste these values in the masterfile but keeping the original format ?
i have several workbooks ans i want to copy the values from the four columns A2:D2 TO LastRow to my masterfile
pasting the below each other
is this possible ???

i suppose that the INTERSECT Is the problem here but i dont know with what i can replace this part of the code ?

Quote:

---

Originally Posted by mdmackillop

Yes. or change this to suit

Code:

---

Path = ThisBk.Path & "\"

---

Minor revisions

Code:

---

Option Explicit
Option Compare Text
Sub test()
    Dim Rng
    Dim sht As Worksheet
    Dim wbk As Workbook
    Dim Filename As String
    Dim Path As String
    Dim ThisBk As Workbook
    Dim Tgt As Range
    Dim Arr, a
    Dim c As Range
    Application.ScreenUpdating = False
    Application.EnableEvents = False
    Arr = Array("ItemID", "XItemID")
    Set ThisBk = ActiveWorkbook
    Path = ThisBk.Path & "\"
    Filename = Dir(Path & "*.xls*")
    Do While Len(Filename) > 0
        If Filename <> ThisWorkbook.Name Then
            Set wbk = Workbooks.Open(Path & Filename, UpdateLinks:=False)
            For Each sht In wbk.Worksheets
                For Each a In Arr
                    Set c = sht.Rows(1).Find(a)
                    If Not c Is Nothing Then
                        Set Tgt = ThisBk.Sheets("Sheet1").Cells(Rows.Count, 1).End(xlUp)(2)
                        On Error Resume Next
                        Intersect(c.EntireColumn, sht.UsedRange).Copy Tgt
                        On Error GoTo 0
                    End If
                Next a
            Next sht
            wbk.Close True
        End If
        Filename = Dir
    Loop
    On Error Resume Next    ThisBk.Sheets("Sheet1").Columns(1).SpecialCells(xlCellTypeBlanks).Delete
    ThisBk.Sheets("Sheet1").Columns(1).SpecialCells(xlCellTypeConstants, xlErrors).Delete
    On Error GoTo 0
    Application.EnableEvents = True
    Application.ScreenUpdating = True
End Sub

---

---