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

I need help to put these codes together and possibly expand. The first piece of code I found online and it should loop through my folder that stores hundreds of workbooks. Once file is opened it should loop through each worksheet in each workbook and look for columns labeled “ItemID” and “XItemID”. Number of worksheets varies and could count from 1 to let’s say 10 or even more. Once column is found the whole content of the column should be copied to NewWorkbook which would store all values found from all files. If there are any blank cells or #N/A found it should be ignored. The second piece of code should look for these columns. To summarize, I need to extract these values from each of these columns and paste them into NewWorkbook, column A. I hope my explanation was precise. Thanks in advance for your help.

Code:

---

Sub MyLoops()
'DECLARE AND SET VARIABLES
Dim wbk As Workbook
Dim Filename As String
Dim Path As String
Path = "C:\Documents\Desktop\MyFiles\"  'CHANGE PATH
Filename = Dir(Path & "*.xlsx")
'OPEN EXCEL FILES
 Do While Len(Filename) > 0  'IF NEXT FILE EXISTS THEN
    Set wbk = Workbooks.Open(Path & Filename)
 
             
 
    wbk.Close True
    Filename = Dir
Loop
End Sub

---

Code:

---

Dim LastColumn1 As Long
Dim LastRow1 As Long
Dim LastRow2 As Long
Dim FindMatch1 As Range
Dim FindMatch2 As Range
 
LastColumn1 = Cells(1, Columns.Count).End(xlToLeft).Column 'Finds last column in worksheet
 
Set FindMatch1 = Range(Cells(1, 1), Cells(1, LastColumn)).Find(What:="ItemID", _
        LookIn:=xlValues, _
        LookAt:=xlWhole, _
        SearchOrder:=xlByRows, _
        SearchDirection:=xlNext, _
        MatchCase:=False) 'Finds position of ItemID column in worksheet
     
 LastRow1 = Cells(Rows.Count, FindMatch1).End(xlUp).Row
 
Set FindMatch2 = Range(Cells(1, 1), Cells(1, LastColumn)).Find(What:="XItemID", _
        LookIn:=xlValues, _
        LookAt:=xlWhole, _
        SearchOrder:=xlByRows, _
        SearchDirection:=xlNext, _
        MatchCase:=False) 'Finds position of XItemID column in worksheet
     
 LastRow2 = Cells(Rows.Count, FindMatch2).End(xlUp).Row

---

I just want to make sure I understand what you are looking for:

you have a folder with a bunch of workbooks
you want to open each and check every sheet for columns labeled: "ItemID" & "XItemID"
if found: you want to copy their contents into a new workbook (new workbook every time? or just on workbook for all of the found columns?)
but exclude blanks and N/A values?
below is just suto code it wouldn't actually run but that is how I would attack this problem.

Code:

---

Sub SutoCode()
    For Each Workbook In FileFolder
          For Each Worksheet In Workbook
              Set ItemIDColumn = ActiveSheet.Cells.Find(“ItemID”)
              If Not ItemIDColumn Is Nothing Then
                    ItemIDColumn.Column.Copy
                    YourWorkbook.Paste
              End If
             
              Set XItemIDColumn = ActiveSheet.Cells.Find("XItemID")
              If Not XItemIDColumn Is Nothing Then
                    XItemIDColumn.Column.Copy
                    YourWorkbook.Paste
              End If
          Next Worksheet
    Next Workbook
   
    With YourWorkbook
          For I = 1 To Sheet1.Cells(Rows.Count, 1).End(xlUp).Row
              If (Cells(I, 1).Value = "N/A" Or Cells(I, 1).Value = "") Then
                    Cells(I, 1).EntireRow.Delete
              End If
          I = I + 1
          Loop
    End With
End Sub

---

Have I understood what you are asking for?

Mincus1308, thank you so much for your reply.

Quote:

---

if found: you want to copy their contents into a new workbook (new workbook every time? or just on workbook for all of the found columns?)

---

This should be only one workbook, and everything should fit into column A. Let's say from first file, we find 50 values, those should be pasted into column A, then second file has 30 values, it should continue through column A where the next empty cell is like A51, etc.

Thanks again.

Ok, I think i can do that. lets do it in steps though.
First thing first, lets step through all of the files in the folder.

Code:

---

Sub Main()'THE MASTER FILE MUST BE SAVED IN THE FILE FOLDER
'ALONG WITH THE WORKBOOKS OF INTEREST
   
'INFORMATION ABOUT YOUR FILE AND FOLDER
    ThePath = ActiveWorkbook.Path
    MyWorkBook = ActiveWorkbook.Name
   
   
    vPath = ThePath & "\*.xls"
    Filename = Dir(vPath)
   
'LOOP THROUGH ALL FILES EXCEPT THE MASTER
    Do While Filename <> ""
          If Filename = MyWorkBook Then GoTo SkipThisFile
          'OPEN THE FILE
          'SEARCH FOR THE COLUMNS OF INTEREST HERE
          'IF FOUND COPY & PASTE
          'CLOSE THE FILE

SkipThisFile:
    Count = Count + 1
    Filename = Dir()
    Loop
End Sub

---

Here ive added the ability to open the file, step through the sheets, and the close the file

Code:

---

Sub Main()'THE MASTER FILE MUST BE SAVED IN THE FILE FOLDER
'ALONG WITH THE WORKBOOKS OF INTEREST
    Dim MyTempWB As Workbook
    Dim WS As Worksheet
   
'INFORMATION ABOUT YOUR FILE AND FOLDER
    Dim MyWB As Workbook
          Set MyWB = ActiveWorkbook
    ThePath = MyWB.Path
    MyWorkBookName = MyWB.Name
   
    vPath = ThePath & "\*.xls"
    Filename = Dir(vPath)
   
'LOOP THROUGH ALL FILES EXCEPT THE MASTER
    Do While Filename <> ""
          If Filename = MyWorkBookName Then GoTo SkipThisFile
    'OPEN NEXT FILE
          Workbooks.Open (CStr(ThePath & "\" & Filename))
          Set MyTempWB = ActiveWorkbook
    'STEP THROUGH EACH SHEET IN THE FILE
              For I = 1 To CInt(MyTempWB.Sheets.Count)
                    'SEARCH THE SHEET FOR VALUE
                   
              Next I
    'CLOSE THE FILE
          ActiveWorkbook.Close
SkipThisFile:
    Count = Count + 1
    Filename = Dir()
    Loop
End Sub

---

baby steps :D

Getting closer:
additions: find and copy the data into the "master" file

Code:

---

Sub Main()'THE MASTER FILE MUST BE SAVED IN THE FILE FOLDER
'ALONG WITH THE WORKBOOKS OF INTEREST
    Dim MyTempWB As Workbook
    Dim WS As Worksheet
   
'INFORMATION ABOUT YOUR FILE AND FOLDER
    Dim MyWB As Workbook
          Set MyWB = ActiveWorkbook
    ThePath = MyWB.Path
    MyWorkBookName = MyWB.Name
       
'LOOP THROUGH ALL FILES EXCEPT THE MASTER
    vPath = ThePath & "\*.xls"
    Filename = Dir(vPath)
    Do While Filename <> ""
          If Filename = MyWorkBookName Then GoTo SkipThisFile
    'OPEN NEXT FILE
          Workbooks.Open (CStr(ThePath & "\" & Filename))
          Set MyTempWB = ActiveWorkbook
    'STEP THROUGH EACH SHEET IN THE FILE
          With MyTempWB
              For I = 1 To CInt(MyTempWB.Sheets.Count)
                    'SEARCH THE SHEET FOR VALUE ItemID AND XItemID
                    Set ItemIDColumn = MyTempWB.Sheets(I).Cells.Find("ItemID", LookIn:=xlValues, LookAt:=xlWhole, SearchOrder:=xlByColumns)
                        If Not ItemIDColumn Is Nothing Then
                              FirstRow = MyTempWB.Sheets(I).Cells(ItemIDColumn.Row + 1, ItemIDColumn.Column).Row
                              LastRow = MyTempWB.Sheets(I).Cells(Rows.Count, ItemIDColumn.Column).End(xlUp).Row
                              Range(MyTempWB.Sheets(I).Cells(FirstRow, ItemIDColumn.Column), MyTempWB.Sheets(I).Cells(LastRow, ItemIDColumn.Column)).Copy
                              MyWB.Activate
                              Sheet1.Cells(Sheet1.Cells(Rows.Count, 1).End(xlUp).Row + 1, 1).Select
                              ActiveSheet.Paste
                              MyTempWB.Activate
                        End If
                    Set XItemIDColumn = MyTempWB.Sheets(I).Cells.Find("XItemID", LookIn:=xlValues, LookAt:=xlWhole, SearchOrder:=xlByColumns)
                        If Not XItemIDColumn Is Nothing Then
                              FirstRow = MyTempWB.Sheets(I).Cells(XItemIDColumn.Row + 1, XItemIDColumn.Column).Row
                              LastRow = MyTempWB.Sheets(I).Cells(Rows.Count, XItemIDColumn.Column).End(xlUp).Row
                              Range(MyTempWB.Sheets(I).Cells(FirstRow, XItemIDColumn.Column), MyTempWB.Sheets(I).Cells(LastRow, XItemIDColumn.Column)).Copy
                              MyWB.Activate
                              Sheet1.Cells(Sheet1.Cells(Rows.Count, 1).End(xlUp).Row + 1, 1).Select
                              ActiveSheet.Paste
                              MyTempWB.Activate
                        End If
              Next I
          End With
    'CLOSE THE FILE
          MyTempWB.Close
SkipThisFile:
    Count = Count + 1
    Filename = Dir()
    Loop
End Sub

---

Im positive that there is a better method, i just dont know it

WELL... It works for me lol

Code:

---

Sub Main()On Error Resume Next
Application.ScreenUpdating = False
'THE MASTER FILE MUST BE SAVED IN THE FILE FOLDER
'ALONG WITH THE WORKBOOKS OF INTEREST
    Dim MyTempWB As Workbook
    Dim WS As Worksheet
'INFORMATION ABOUT YOUR FILE AND FOLDER
    Dim MyWB As Workbook
          Set MyWB = ActiveWorkbook
    ThePath = MyWB.Path
    MyWorkBookName = MyWB.Name
    Sheet1.Cells(1, 1).Value = "ItemID's"
'LOOP THROUGH ALL FILES EXCEPT THE MASTER
    vPath = ThePath & "\*.xls"
    Filename = Dir(vPath)
    Do While Filename <> ""
          If Filename = MyWorkBookName Then GoTo SkipThisFile
    'OPEN NEXT FILE
          Workbooks.Open (CStr(ThePath & "\" & Filename))
          Set MyTempWB = ActiveWorkbook
    'STEP THROUGH EACH SHEET IN THE FILE
          With MyTempWB
              For I = 1 To CInt(MyTempWB.Sheets.Count)
                    'SEARCH THE SHEET FOR VALUE ItemID AND XItemID
                    Set ItemIDColumn = MyTempWB.Sheets(I).Cells.Find("ItemID", LookIn:=xlValues, LookAt:=xlWhole, SearchOrder:=xlByColumns)
                        If Not ItemIDColumn Is Nothing Then
                              FirstRow = MyTempWB.Sheets(I).Cells(ItemIDColumn.Row + 1, ItemIDColumn.Column).Row
                              LastRow = MyTempWB.Sheets(I).Cells(Rows.Count, ItemIDColumn.Column).End(xlUp).Row
                              Range(MyTempWB.Sheets(I).Cells(FirstRow, ItemIDColumn.Column), MyTempWB.Sheets(I).Cells(LastRow, ItemIDColumn.Column)).Copy
                              MyWB.Activate
                              Sheet1.Cells(Sheet1.Cells(Rows.Count, 1).End(xlUp).Row + 1, 1).Select
                              ActiveSheet.Paste
                              MyTempWB.Activate
                        End If
                    Set XItemIDColumn = MyTempWB.Sheets(I).Cells.Find("XItemID", LookIn:=xlValues, LookAt:=xlWhole, SearchOrder:=xlByColumns)
                        If Not XItemIDColumn Is Nothing Then
                              FirstRow = MyTempWB.Sheets(I).Cells(XItemIDColumn.Row + 1, XItemIDColumn.Column).Row
                              LastRow = MyTempWB.Sheets(I).Cells(Rows.Count, XItemIDColumn.Column).End(xlUp).Row
                              Range(MyTempWB.Sheets(I).Cells(FirstRow, XItemIDColumn.Column), MyTempWB.Sheets(I).Cells(LastRow, XItemIDColumn.Column)).Copy
                              MyWB.Activate
                              Sheet1.Cells(Sheet1.Cells(Rows.Count, 1).End(xlUp).Row + 1, 1).Select
                              ActiveSheet.Paste
                              MyTempWB.Activate
                        End If
              Next I
          End With
    'CLOSE THE FILE
          MyTempWB.Close
SkipThisFile:
    Count = Count + 1
    Filename = Dir()
    Loop
'AT THIS POINT EVERYTHING HAS BEEN MOVED
'NOW LETS LOOP BACK THROUGH AND REMOVE YOUR N/A & BLANK VALUES
    MyWB.Activate
    For I = 1 To Sheet1.Cells(Rows.Count, 1).End(xlUp).Row
          If IsError(Sheet1.Cells(I, 1).Value) Then Sheet1.Cells(I, 1).EntireRow.Delete
          If Sheet1.Cells(I, 1).Value = "" Then Sheet1.Cells(I, 1).EntireRow.Delete
          If Sheet1.Cells(I, 1).Value = "#N/A" Then Sheet1.Cells(I, 1).EntireRow.Delete
    Next I
Application.ScreenUpdating = True
On Error GoTo 0
    MyWB.Save
End Sub

---

Best Of Luck!
If this code works for you please mark the thread as solved

This searches only Row 1 for the headers.

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
    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
                        c.EntireColumn.SpecialCells(2).Copy Tgt
                        Set Tgt = ThisBk.Sheets("Sheet1").Cells(Rows.Count, 1).End(xlUp)(2)
                        c.SpecialCells(-4123).Copy Tgt
                        On Error GoTo 0
                    End If
                Next a
            Next sht
            wbk.Close True
        End If
        Filename = Dir
    Loop
    Application.ScreenUpdating = True
End Sub

---

:( its so pretty....
barim, that's the difference between a grand master and a contributor...

@Mincus
Let's wait until he's tested both! Yours is maybe more robust.
Regards
MD

Mincus and mdmackillop, I just want to thank you both for working on this issue. I haven't tested it yet, will do it sometimes tomorrow. You both rock! I hope one day I will be skilled in VBA as you are. I will let you know if I encounter any errors.

No Problem!
I love trying to solve these puzzles - It forces me to get better.
Just remember when you get as good as mdmackillop to come back and help out :hi:

I've tested mdmackillop's macro and it prompts me about my target workbook. It says that "my file is already open. Reopening will cause any changes you made to be discarded. Do you want to reopen your file? When I click No it points me to this line of code:

Code:

---

Set wbk = Workbooks.Open(Path & Filename, UpdateLinks:=False)

---

and I can see that only 300 rows have been populated.

When I click Yes, it points me to this line of code:

Code:

---

Set Tgt = ThisBk.Sheets("Sheet1").Cells(Rows.Count, 1).End(xlUp)(2)

---

Where should I save my target workbook? In the same folder with other files? When I save it outside of the folder it doesn't even activate the macro.
I am going to test now MINCUS1308's macro.

Thanks.

Quote:

---

Where should I save my target workbook? In the same folder with other files?

---

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

---

presumably - mine worked :) ?!?

Hi Mincus
A couple of tweaks to your code marked '@@@. I would also suggerst finding a method to remove Activate and Select from your method.

Code:

---

Sub Main()
On Error Resume Next
    Application.ScreenUpdating = False
    Application.EnableEvents = False    '@@@  Prevent On-Open and other Event macros etc. from running
    'THE MASTER FILE MUST BE SAVED IN THE FILE FOLDER
    'ALONG WITH THE WORKBOOKS OF INTEREST
    Dim MyTempWB As Workbook
    Dim WS As Worksheet
    'INFORMATION ABOUT YOUR FILE AND FOLDER
    Dim MyWB As Workbook
    Set MyWB = ActiveWorkbook
    ThePath = MyWB.Path
    MyWorkBookName = MyWB.Name
    Sheet1.Cells(1, 1).Value = "ItemID's"
    'LOOP THROUGH ALL FILES EXCEPT THE MASTER
    vPath = ThePath & "\*.xls"  '@@@    maybe *.xl* for more general application
    Filename = Dir(vPath)
    Do While Filename <> ""
        If Filename = MyWorkBookName Then GoTo SkipThisFile
        'OPEN NEXT FILE
        Workbooks.Open (CStr(ThePath & "\" & Filename)), False  '@@@  Prevent link upates
        Set MyTempWB = ActiveWorkbook
        'STEP THROUGH EACH SHEET IN THE FILE
        With MyTempWB
            For I = 1 To CInt(MyTempWB.Sheets.Count)
                'SEARCH THE SHEET FOR VALUE ItemID AND XItemID
                Set ItemIDColumn = MyTempWB.Sheets(I).Cells.Find("ItemID", LookIn:=xlValues, LookAt:=xlWhole, SearchOrder:=xlByColumns)
                If Not ItemIDColumn Is Nothing Then
                    FirstRow = MyTempWB.Sheets(I).Cells(ItemIDColumn.Row + 1, ItemIDColumn.Column).Row
                    LastRow = MyTempWB.Sheets(I).Cells(Rows.Count, ItemIDColumn.Column).End(xlUp).Row
                    Range(MyTempWB.Sheets(I).Cells(FirstRow, ItemIDColumn.Column), MyTempWB.Sheets(I).Cells(LastRow, ItemIDColumn.Column)).Copy
                    MyWB.Activate
                    Sheet1.Cells(Sheet1.Cells(Rows.Count, 1).End(xlUp).Row + 1, 1).Select
                    ActiveSheet.Paste
                    MyTempWB.Activate
                End If
                Set XItemIDColumn = MyTempWB.Sheets(I).Cells.Find("XItemID", LookIn:=xlValues, LookAt:=xlWhole, SearchOrder:=xlByColumns)
                If Not XItemIDColumn Is Nothing Then
                    FirstRow = MyTempWB.Sheets(I).Cells(XItemIDColumn.Row + 1, XItemIDColumn.Column).Row
                    LastRow = MyTempWB.Sheets(I).Cells(Rows.Count, XItemIDColumn.Column).End(xlUp).Row
                    Range(MyTempWB.Sheets(I).Cells(FirstRow, XItemIDColumn.Column), MyTempWB.Sheets(I).Cells(LastRow, XItemIDColumn.Column)).Copy
                    MyWB.Activate
                    Sheet1.Cells(Sheet1.Cells(Rows.Count, 1).End(xlUp).Row + 1, 1).Select
                    ActiveSheet.Paste
                    MyTempWB.Activate
                End If
            Next I
        End With
        'CLOSE THE FILE
        MyTempWB.Close False '@@@  don't save changes
SkipThisFile:
        Count = Count + 1
        Filename = Dir()
    Loop
    'AT THIS POINT EVERYTHING HAS BEEN MOVED
    'NOW LETS LOOP BACK THROUGH AND REMOVE YOUR N/A & BLANK VALUES
    MyWB.Activate
    For I = 1 To Sheet1.Cells(Rows.Count, 1).End(xlUp).Row
        If IsError(Sheet1.Cells(I, 1).Value) Then Sheet1.Cells(I, 1).EntireRow.Delete
        If Sheet1.Cells(I, 1).Value = "" Then Sheet1.Cells(I, 1).EntireRow.Delete
        If Sheet1.Cells(I, 1).Value = "#N/A" Then Sheet1.Cells(I, 1).EntireRow.Delete
    Next I
    Application.ScreenUpdating = True
    Application.EnableEvents = True
    On Error GoTo 0
    MyWB.Save
End Sub

---

@mdmackillop
I didn't even consider the possibility of macro events - that could have turned into a mess real fast!

I struggled with stepping back and forth between the workbooks. Other than the activate and select methods how is this supposed to be achieved?

Quote:

---

Originally Posted by MINCUS1308

Other than the activate and select methods how is this supposed to be achieved?

---

As long as you fully reference the ranges, Excel will switch between the locations. As you are using a With statement, repeated use of MyTempWB is not required. The target location is only required for the Paste destination. Also, ensure you're only searching WorkSheets. Search will fail if the sheet is a Chart

Code:

---

'STEP THROUGH EACH SHEET IN THE FILE
        With MyTempWB
            For I = 1 To .WorkSheets.Count
                'SEARCH THE SHEET FOR VALUE ItemID AND XItemID
                Set ItemIDColumn = .WorkSheets(I).Cells.Find("ItemID", LookIn:=xlValues, LookAt:=xlWhole, SearchOrder:=xlByColumns)
                If Not ItemIDColumn Is Nothing Then
                    FirstRow = .WorkSheets(I).Cells(ItemIDColumn.Row + 1, ItemIDColumn.Column).Row
                    LastRow = .WorkSheets(I).Cells(Rows.Count, ItemIDColumn.Column).End(xlUp).Row
                    Range(.WorkSheets(I).Cells(FirstRow, ItemIDColumn.Column), .WorkSheets(I).Cells(LastRow, ItemIDColumn.Column)).Copy _
                    MyWB.Sheet1.Cells(Rows.Count, 1).End(xlUp).Offset(1)
                End If

---

MINCUS1308 - when I ran your macro (before mdmackillop's revisions to your code), I experienced a series of Edit Links/Continue. I had to stop running this macro. I ran your macro after revision and I had series of prompts: "There's already data here. Do you want to replace it?" I clicked No and after that appeared: "There's a large amount of data in Clipboard. To save it click Yes, to free memory click No." I clicked No in order to free memory.

mdmackillop - I ran your macro after you did minor revisions and I still have problem with that open file. I open my target file which I called "AllItems". Now, if I leave it open I am promted with message: "Your file is already open, do you wish to close it". If I close file and try to run macro again nothing happens. I also have my personal xlsb file that is opening every time I open first excel file. Is this affecting anything?

UPDATE: Before I ran this code I had to change these values in the array:

Code:

---

Arr = Array("ItemID", "XItemID")

---

When I use these values I do not have any error messages. Why is it not working if you change the column labels that you are searching for?

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

---

---