PDA

View Full Version : Loop Through Multiple Workbooks/Sheets And Extract Values From Columns With Label



barim
06-21-2017, 08:20 AM
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.



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





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

MINCUS1308
06-21-2017, 10:51 AM
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.


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?

barim
06-21-2017, 11:37 AM
Mincus1308, thank you so much for your reply.


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.

MINCUS1308
06-21-2017, 01:41 PM
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.


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

MINCUS1308
06-21-2017, 02:04 PM
Here ive added the ability to open the file, step through the sheets, and the close the file

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

MINCUS1308
06-21-2017, 02:47 PM
Getting closer:
additions: find and copy the data into the "master" file

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

MINCUS1308
06-21-2017, 03:05 PM
WELL... It works for me lol


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

mdmackillop
06-21-2017, 03:35 PM
This searches only Row 1 for the headers.

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

MINCUS1308
06-22-2017, 05:07 AM
:( its so pretty....
barim, that's the difference between a grand master and a contributor...

mdmackillop
06-22-2017, 08:58 AM
@Mincus
Let's wait until he's tested both! Yours is maybe more robust.
Regards
MD

barim
06-22-2017, 06:40 PM
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.

MINCUS1308
06-23-2017, 06:07 AM
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:

barim
06-23-2017, 11:41 AM
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:


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:


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.

mdmackillop
06-24-2017, 10:06 AM
Where should I save my target workbook? In the same folder with other files?
Yes. or change this to suit

Path = ThisBk.Path & "\"
Minor revisions

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

MINCUS1308
06-24-2017, 11:08 AM
presumably - mine worked :) ?!?

mdmackillop
06-25-2017, 04:24 AM
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.

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

MINCUS1308
06-26-2017, 05:11 AM
@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?

mdmackillop
06-26-2017, 08:38 AM
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

'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

barim
06-26-2017, 10:38 AM
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?

barim
06-26-2017, 10:56 AM
UPDATE: Before I ran this code I had to change these values in the array:
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?

mdmackillop
06-26-2017, 12:33 PM
Here is my test sample

barim
06-26-2017, 01:30 PM
It worked after I changed this line of code:


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

to:


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.

mdmackillop
06-26-2017, 02:21 PM
Happy you got it sorted.

EMRBR
06-07-2018, 01:16 PM
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 ?


Yes. or change this to suit

Path = ThisBk.Path & "\"
Minor revisions

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