Consulting

Page 1 of 2 1 2 LastLast
Results 1 to 20 of 24

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

  1. #1
    VBAX Regular
    Joined
    Jan 2016
    Posts
    55
    Location

    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.

    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

  2. #2
    VBAX Tutor MINCUS1308's Avatar
    Joined
    Jun 2014
    Location
    UNDER MY DESK
    Posts
    254
    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?
    - I HAVE NO IDEA WHAT I'M DOING

  3. #3
    VBAX Regular
    Joined
    Jan 2016
    Posts
    55
    Location
    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.

  4. #4
    VBAX Tutor MINCUS1308's Avatar
    Joined
    Jun 2014
    Location
    UNDER MY DESK
    Posts
    254
    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
    - I HAVE NO IDEA WHAT I'M DOING

  5. #5
    VBAX Tutor MINCUS1308's Avatar
    Joined
    Jun 2014
    Location
    UNDER MY DESK
    Posts
    254
    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
    - I HAVE NO IDEA WHAT I'M DOING

  6. #6
    VBAX Tutor MINCUS1308's Avatar
    Joined
    Jun 2014
    Location
    UNDER MY DESK
    Posts
    254
    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
    - I HAVE NO IDEA WHAT I'M DOING

  7. #7
    VBAX Tutor MINCUS1308's Avatar
    Joined
    Jun 2014
    Location
    UNDER MY DESK
    Posts
    254
    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
    - I HAVE NO IDEA WHAT I'M DOING

  8. #8
    Administrator
    VP-Knowledge Base
    VBAX Grand Master mdmackillop's Avatar
    Joined
    May 2004
    Location
    Scotland
    Posts
    14,489
    Location
    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
    MVP (Excel 2008-2010)

    Post a workbook with sample data and layout if you want a quicker solution.


    To help indent your macros try Smart Indent

    Please remember to mark threads 'Solved'

  9. #9
    VBAX Tutor MINCUS1308's Avatar
    Joined
    Jun 2014
    Location
    UNDER MY DESK
    Posts
    254
    its so pretty....
    barim, that's the difference between a grand master and a contributor...
    - I HAVE NO IDEA WHAT I'M DOING

  10. #10
    Administrator
    VP-Knowledge Base VBAX Grand Master mdmackillop's Avatar
    Joined
    May 2004
    Location
    Scotland
    Posts
    14,489
    Location
    @Mincus
    Let's wait until he's tested both! Yours is maybe more robust.
    Regards
    MD
    MVP (Excel 2008-2010)

    Post a workbook with sample data and layout if you want a quicker solution.


    To help indent your macros try Smart Indent

    Please remember to mark threads 'Solved'

  11. #11
    VBAX Regular
    Joined
    Jan 2016
    Posts
    55
    Location
    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.

  12. #12
    VBAX Tutor MINCUS1308's Avatar
    Joined
    Jun 2014
    Location
    UNDER MY DESK
    Posts
    254
    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
    - I HAVE NO IDEA WHAT I'M DOING

  13. #13
    VBAX Regular
    Joined
    Jan 2016
    Posts
    55
    Location
    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.

  14. #14
    Administrator
    VP-Knowledge Base VBAX Grand Master mdmackillop's Avatar
    Joined
    May 2004
    Location
    Scotland
    Posts
    14,489
    Location
    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
    MVP (Excel 2008-2010)

    Post a workbook with sample data and layout if you want a quicker solution.


    To help indent your macros try Smart Indent

    Please remember to mark threads 'Solved'

  15. #15
    VBAX Tutor MINCUS1308's Avatar
    Joined
    Jun 2014
    Location
    UNDER MY DESK
    Posts
    254
    presumably - mine worked ?!?
    - I HAVE NO IDEA WHAT I'M DOING

  16. #16
    Administrator
    VP-Knowledge Base VBAX Grand Master mdmackillop's Avatar
    Joined
    May 2004
    Location
    Scotland
    Posts
    14,489
    Location
    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
    MVP (Excel 2008-2010)

    Post a workbook with sample data and layout if you want a quicker solution.


    To help indent your macros try Smart Indent

    Please remember to mark threads 'Solved'

  17. #17
    VBAX Tutor MINCUS1308's Avatar
    Joined
    Jun 2014
    Location
    UNDER MY DESK
    Posts
    254
    @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?
    - I HAVE NO IDEA WHAT I'M DOING

  18. #18
    Administrator
    VP-Knowledge Base VBAX Grand Master mdmackillop's Avatar
    Joined
    May 2004
    Location
    Scotland
    Posts
    14,489
    Location
    Quote Originally Posted by MINCUS1308 View Post
    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
    MVP (Excel 2008-2010)

    Post a workbook with sample data and layout if you want a quicker solution.


    To help indent your macros try Smart Indent

    Please remember to mark threads 'Solved'

  19. #19
    VBAX Regular
    Joined
    Jan 2016
    Posts
    55
    Location
    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?

  20. #20
    VBAX Regular
    Joined
    Jan 2016
    Posts
    55
    Location
    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?

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts
  •