Multiple For Each Statements Help

speed88bump

New Member
Joined
Aug 9, 2013
Messages
29
I am writing a procedure that will require multiple uses of the For Each statement and If Statements in between. I am having a very hard time wrapping my head around this, as such I am having a hard time writing it. I am hoping you guys can help me make since of it all.
I have a Master sheet within Excel in which that macro is in. Within this workbook it has 3 sheets. ST, SH and Data Files.
The Data Files Worksheet starting in Cell H3 has a list of the Folder\File Names locations from the Workbooks I need to pull data from. (Within each workbook is 1-5 separate worksheets in which I will need to extract data from based on criteria).
Starting in Cell B3 of the Data Files Worksheet I have Filenames listed separate from the Folder\File Names mentioned previously.
I am needing to open up each Workbook listed as "read only" and For each worksheet select Row 36 and search for today's date. If not true then go to next worksheet. If True, Then select cell and set as strRng Select entire Column and Offset -1 to select previous column and Hide Selected Columns to Q:Q.
The data can be filtered or I assume it may be easier to reference an adjacent cell like an index match not sure. One problem with filtering is when the Next cell is selected it may not be the visible cell and pull data from the wrong cell.
I used autofilter method. There are filters from B37:P37 on each worksheet. I filtered O37 (Field 14) = "BALANCE" Then starting in strRng until last row For Each cell that is < 0 I need to extract that cell and input it into the Master Workbook Column E contains either an ST or SH If the cell in column E = ST it will go into the Master Workbook Sheet ST and if SH into sheet SH. Example if the cell = ST then it needs to extract the adjoining cell in column H and extract/copy/paste it to sheet ST and placed in the first empty cell in column E. The Negative number it found under "BALANCE" would be selected along with the next 3 cells to the right and Copied/Pasted into ST column E (which is under a field with today's date each column after that is the next day). I need it to also extract Col K and place it in ST Col B, Col C to ST C, Col H to ST I. Then go to next Cell and continue this until it is complete.
Once it has gone through each worksheet it will close without saving the file it opened. and move to the next file listed on the Data Files Work Sheet. And do this until it has gone through all files listed.

Code:
Sub CreateSubsetWorkbook()
    
    Dim wbkOutput As Workbook, WKB As Workbook
    Dim wksOutputA As Worksheet, wksOutputB As Worksheet, wks As Worksheet
    Dim lngLastRow As Long, LngLastCol As Long, lngDateRow As Long, Lrow As Long, LLRow As Long
    Dim rngFull As Range, rngResult As Range, rngTarget As Range, My_Range As Range, MyRange As Range, strRng As Range
    Dim strStart As String, strEnd As String
    Dim MyPath As String
    
    Set wbkOutput = Workbooks("Auto GEMBA Generation.xlsm")
    'Create a new worksheet in the output workbook
            Set wksOutputA = Sheets("Struts")
            Set wksOutputB = Sheets("Shocks")
    strStart = Sheets("Struts").Range("E1").Value
    strEnd = Sheets("Struts").Range("H1").Value
    Sheets("Data Files").Select
    Set My_Range = Range("H2:H13") '& LastRow(ActiveSheet))
                
                If ActiveWorkbook.ProtectStructure = True Or _
                   My_Range.Parent.ProtectContents = True Then
                    MsgBox "Sorry, not working when the workbook or worksheet is protected", _
                           vbOKOnly, "Copy to new workbook"
                    Exit Sub
                End If
                
    With Sheets("Data Files")
        Lrow = .Cells(Rows.Count, "H").End(xlUp).Row
        For Each cell In .Range("H3:H" & Lrow)
        MyPath = cell
        Range(cell).Select
        WKB = ActiveCell.Offset(0, -6).Value
        WKB.Open (cell), ReadOnly:=True
        WKB.Activate
    
        
    'Loop through each worksheet
    For Each wks In ThisWorkbook.Worksheets
        With wks
           Rows(36).Select
           If Cells.Find(What:=strStart, After:=ActiveCell, LookIn:=xlFormulas, _
            LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
            MatchCase:=False, SearchFormat:=False).Activate = True Then
        Set strRng = ActiveCell
        LngLastCol = ActiveCell.Columns("A:A").EntireColumn
        LLRow = .Cells(Rows.Count, "strRng").End(xlUp).Row
    For Each cell In .Range("strRng" & LLRow)
        If cell < 0 Then
        
        Set MyRange = Range("strRng" & LastRow(ActiveSheet))
            
            
            
            
            
            
            'Create a destination range on the new worksheet that we
            'will copy our filtered data to
            Set rngTarget = wksOutputA.Cells(5, 2)
        
            'Identify the data range on this sheet for the autofilter step
            'by finding the last row and the last column
            lngLastRow = .Cells.Find(What:="*", LookIn:=xlFormulas, _
                                 SearchOrder:=xlByRows, _
                                 SearchDirection:=xlPrevious).Row
            LngLastCol = .Cells.Find(What:="*", LookIn:=xlFormulas, _
                                 SearchOrder:=xlByColumns, _
                                 SearchDirection:=xlPrevious).Column
            Set rngFull = .Range(.Cells(1, 1), .Cells(lngLastRow, LngLastCol))
            
            'Apply a filter to the full range to get only rows that
            'are in between the input dates
            With rngFull
                .AutoFilter Field:=lngDateRow, _
                            Criteria1:=">=" & StartDate, _
                            Criteria2:="<=" & EndDate
                
                'Copy only the visible cells and paste to the
                'new worksheet in our output workbook
                Set rngResult = rngFull.SpecialCells(xlCellTypeVisible)
                rngResult.Copy Destination:=rngTarget
            End With
            
            'Clear the autofilter safely
            .AutoFilterMode = False
            If .FilterMode = True Then
                .ShowAllData
            End If
        
    Next wks
    End With
    
    'Let the user know our macro has finished!
    MsgBox "Data transferred!"

End Sub

Function LastRow(sh As Worksheet)
    On Error Resume Next
    LastRow = sh.Cells.Find(What:="*", _
                            After:=sh.Range("A1"), _
                            LookAt:=xlPart, _
                            LookIn:=xlValues, _
                            SearchOrder:=xlByRows, _
                            SearchDirection:=xlPrevious, _
                            MatchCase:=False).Row
    On Error GoTo 0
End Function
 
Last edited by a moderator:

Excel Facts

Last used cell?
Press Ctrl+End to move to what Excel thinks is the last used cell.

Forum statistics

Threads
1,214,641
Messages
6,120,692
Members
448,979
Latest member
DET4492

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
Back
Top