Assigning Function Values To For Loop

[Hashiru]

Hi everyone,

I will like to assign the Top and Bottom values on my filtered sheet to the start and last values on the for loop but I am not getting it right.

see code below:

Sub MList()
Dim TempBk As Workbook, ContactBk As Workbook, ExportBk As Workbook
Dim TempSh As Worksheet, ContactSh As Worksheet, ExportSh As Worksheet
Dim ExportPath   As Variant


Set TempBk = ThisWorkbook
Set TempSh = TempBk.Worksheets("EmailList")
Set TempSh1 = TempBk.Worksheets("ClientContacts")
'Clear old records
   ThisWorkbook.Activate
   NumOfRecord = TempSh.Cells(Rows.Count, 1).End(xlUp).Row
   NumOfRecord1 = TempSh1.Cells(Rows.Count, 1).End(xlUp).Row


TempSh.Activate
On Error Resume Next
    TempSh.Cells(1, 1).Resize(NumOfRecord, 32).Select
    Range(Selection, Selection.End(xlDown)).Clear
On Error GoTo 0
TempSh1.Activate
On Error Resume Next
    TempSh1.Cells(1, 1).Resize(NumOfRecord, 15).Select
    Range(Selection, Selection.End(xlDown)).Clear
On Error GoTo 0
   ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
   'Browse for the first Datasource and set the title of the dialog box.
    Set MyFirstFile = Application.FileDialog(msoFileDialogFilePicker)
    With MyFirstFile
        
    .Title = "Browse for the Client Export Report (Service Bureau Report)"
        If .Show = True Then
         ' Assign the file to a variable xfilepath1.
            ExportFilePath = MyFirstFile.SelectedItems.Item(1)
 
            Else
               MsgBox "You clicked Cancel in the file dialog box.", , "Canceling the data extraction process"
                Exit Sub
        End If
    End With
    'ExportFileName = Mid(ExportFilePath, InStrRev(ExportFilePath, "\") + 1, 13)
    
  ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
  'Browse for the second Datasource and set the title of the dialog box.
    Set MySecondFile = Application.FileDialog(msoFileDialogFilePicker)
    With MySecondFile
        
    .Title = "Browse for the Client_Contact_Listing ... file"
        If .Show = True Then
         ' Assign the file to a variable xfilepath2.
            ContactFilePath = MySecondFile.SelectedItems.Item(1)
 
            Else
               MsgBox "You clicked Canncel in the file dialog box.", , "Canceling the data extraction process"
                Exit Sub
        End If
    End With
    'ContactFileName = Mid(ContactFilePath, InStrRev(ContactFilePath, "\") + 1, 14)
    'Ensure correct copying of files to appropriate tabs
    If Mid(ExportFilePath, InStrRev(ExportFilePath, "\") + 1, 13) = "Client_Export" Then
        Set ExportBk = Workbooks.Open(ExportFilePath, 0)
        Set ExportSh = ExportBk.Worksheets(1)
        RECORDNUM1 = ExportSh.Cells(Rows.Count, 1).End(xlUp).Row
        ExportSh.Cells(1, 1).Resize(RECORDNUM1, 32).Copy TempSh.Cells(1, 1)
        ExportBk.Close
    ElseIf Mid(ExportFilePath, InStrRev(ExportFilePath, "\") + 1, 14) = "Client_Contact" Then
        Set ContactBk = Workbooks.Open(ContactFilePath, 0)
        Set ContactSh = ContactBk.Worksheets(1)
        RECORDNUM2 = ContactSh.Cells(Rows.Count, 1).End(xlUp).Row
        ContactSh.Cells(1, 1).Resize(RECORDNUM2, 32).Copy TempSh.Cells(1, 1)
        ContactBk.Close
    End If
   
    If Mid(ContactFilePath, InStrRev(ContactFilePath, "\") + 1, 13) = "Client_Export" Then
        Set ExportBk = Workbooks.Open(ExportFilePath, 0)
        Set ExportSh = ExportBk.Worksheets(1)
        RECORDNUM1 = ExportSh.Cells(Rows.Count, 1).End(xlUp).Row
        ExportSh.Cells(1, 1).Resize(RECORDNUM1, 32).Copy TempSh1.Cells(1, 1)
        ExportBk.Close
    ElseIf Mid(ContactFilePath, InStrRev(ContactFilePath, "\") + 1, 14) = "Client_Contact" Then
        Set ContactBk = Workbooks.Open(ContactFilePath, 0)
        Set ContactSh = ContactBk.Worksheets(1)
        RECORDNUM2 = ContactSh.Cells(Rows.Count, 1).End(xlUp).Row
        ContactSh.Cells(1, 1).Resize(RECORDNUM2, 32).Copy TempSh1.Cells(1, 1)
    End If


   '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
    
    'Filter relevant records and delete unwanted Rows from source data
    TempBk.Activate: TempSh.Activate
    TempSh.Rows("3:3").Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
    TempSh.Range("A3").Resize(1, 32).FormulaR1C1 = "=IF(R[-2]C="""",R[-1]C,CONCATENATE(R[-2]C,"" "",R[-1]C))"
    TempSh.Rows("3:3").Select
    Selection.Copy
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    TempSh.Rows("1:2").Delete Shift:=xlUp


    TempSh.Cells(1, 1).Resize(1, 32).Copy TempSh.Cells(RECORDNUM1 + 5, 1)
    
    TempSh.Cells(RECORDNUM1 + 6, 1) = "<>A*"
    TempSh.Cells(RECORDNUM1 + 6, 8) = "Electronic All by Client"
    TempSh.Cells(RECORDNUM1 + 6, 10) = "<>Terminated"
    
    TempSh.Cells(1, 1).Resize(1, 32).Copy TempSh.Cells(RECORDNUM1 + 10, 1)
    TempSh.Range("C" & RECORDNUM1 + 10 & ":G" & RECORDNUM1 + 10).Delete Shift:=xlToLeft
    TempSh.Range("D" & RECORDNUM1 + 10).Delete Shift:=xlToLeft
    TempSh.Range("E" & RECORDNUM1 + 10 & ":R" & RECORDNUM1 + 10).Delete Shift:=xlToLeft
    TempSh.Range("G" & RECORDNUM1 + 10).Delete Shift:=xlToLeft
    TempSh.Range("L" & RECORDNUM1 + 10).Delete Shift:=xlToLeft


    TempSh.Range("A1:AG" & RECORDNUM1 - 1).AdvancedFilter Action:=xlFilterCopy, CriteriaRange:=TempSh.Range("A" & RECORDNUM1 + 5 & ":AF" & RECORDNUM1 + 6), CopyToRange:=TempSh.Range("A" & RECORDNUM1 + 10 & ":K" & RECORDNUM1 + 10)
    TempSh.Rows("1:" & RECORDNUM1 + 9).Delete Shift:=xlUp
    
    RECORDNUM1 = TempSh.Cells(Rows.Count, 1).End(xlUp).Row
    TempSh.Cells(1, 1).Resize(1, 11).Copy TempSh.Cells(RECORDNUM1 + 5, 1)
    TempSh.Cells(RECORDNUM1 + 6, 4) = "<>Term W/ Access"
    TempSh.Range("A1:K" & RECORDNUM1).AdvancedFilter Action:=xlFilterCopy, CriteriaRange:=TempSh.Range("A" & RECORDNUM1 + 5 & ":K" & RECORDNUM1 + 6), CopyToRange:=TempSh.Range("A" & RECORDNUM1 + 10)
    TempSh.Rows("1:" & RECORDNUM1 + 9).Delete Shift:=xlUp


    TempSh.Columns("A:K").ColumnWidth = 30
    TempSh.Columns("A:K").EntireColumn.AutoFit
    TempSh1.Columns("C:D").Delete Shift:=xlToLeft
    
    TotalRow = TempSh1.Cells(Rows.Count, 1).End(xlUp).Row
    TempSh1.Cells(1, 1).Resize(1, 15).Copy TempSh1.Cells(TotalRow + 5, 1)
    
    TempSh1.Cells(TotalRow + 6, 8) = "<>*@payrollnetwork.com"
    TempSh1.Range("A1:O" & TotalRow).AdvancedFilter Action:=xlFilterCopy, CriteriaRange:=TempSh1.Range("A" & TotalRow + 5 & ":O" & TotalRow + 6), CopyToRange:=TempSh1.Range("A" & TotalRow + 10)
    TempSh1.Rows("1:" & TotalRow + 9).Delete Shift:=xlUp
    TempSh1.Range("C:E,I:O").Delete Shift:=xlToLeft
    TempSh1.Columns("A:E").ColumnWidth = 30
    TempSh1.Columns("A:E").EntireColumn.AutoFit
    
    TempSh.Range("A1:K1").AutoFilter
    TempSh.Range("$A$1:$K" & TotalRow).AutoFilter Field:=2, Criteria1:="National Association of State Departments of Agriculture"
    StartProc = GetFilteredRangeTopRow
    EndProc = GetFilteredRangeBottonRow
    
        For i = StartProc To EndProc
            If Not (OldSht.Cells(i, 2)) = "Elizabeth Rowland NASDA HQ ONLY" Or Not (OldSht.Cells(i, 2)) = "Elizabeth Rowland NASDA HQ ONLY" Or Not (OldSht.Cells(i, 2)) = "Elizabeth Rowland NASDA HQ ONLY" Then
                TempSh1.Rows(i & ":" & i).Delete Shift:=xlUp
            End If
        Next i




End Sub
Function GetFilteredRangeTopRow() As Long
  Dim HeaderRow As Long, LastFilterRow As Long
  On Error GoTo NoFilterOnSheet
  With ActiveSheet
    HeaderRow = .AutoFilter.Range(1).Row
    LastFilterRow = .Range(Split(.AutoFilter.Range.Address, ":")(1)).Row
    GetFilteredRangeTopRow = .Range(.Rows(HeaderRow + 1), .Rows(Rows.Count)). _
                                    SpecialCells(xlCellTypeVisible)(1).Row
    If GetFilteredRangeTopRow = LastFilterRow + 1 Then GetFilteredRangeTopRow = 0
  End With
NoFilterOnSheet:
End Function
 
Function GetFilteredRangeBottomRow() As Long
  Dim HeaderRow As Long, LastFilterRow As Long, Addresses() As String
  On Error GoTo NoFilterOnSheet
  With ActiveSheet
    HeaderRow = .AutoFilter.Range(1).Row
    LastFilterRow = .Range(Split(.AutoFilter.Range.Address, ":")(1)).Row
    Addresses = Split(.Range((HeaderRow + 1) & ":" & LastFilterRow). _
                      SpecialCells(xlCellTypeVisible).Address, "$")
    GetFilteredRangeBottomRow = Addresses(UBound(Addresses))
  End With
NoFilterOnSheet:
End Function

 

[StephenCrump]

... but I am not getting it right.

Potentially there are many things that could be going wrong. It would help if you could be more specific about what is happening, or not happening.

My first guess is that the problem is with your loop:

For i = StartProc To EndProc
    If Not (OldSht.Cells(i, 2)) = "Elizabeth Rowland NASDA HQ ONLY" Or Not (OldSht.Cells(i, 2)) = "Elizabeth Rowland NASDA HQ ONLY" Or Not (OldSht.Cells(i, 2)) = "Elizabeth Rowland NASDA HQ ONLY" Then
        TempSh1.Rows(i & ":" & i).Delete shift:=xlUp
    End If
Next i

Suppose based on this test, you want to delete rows 10 and 15. When you delete row 10, row 15 becomes row 14 so you'll end up deleting the wrong row. Instead, try looping backwards like this:

For i = EndProc To StartProc Step -1

Does that fix the problem?

 

[Hashiru]

Thanks StephenCrump

I want to loop throw a subset of a range so I did a filter. Next I used functions to determine the first and last rows of the filtered range, then I loop through the from the first and last rows. This is to avoid looping through the entire population. Thanks for aligning me with the correct approach to delete rows. The code has been running fine up to the point of determining the rows to loop through.

 

[StephenCrump]

On closer inspection, you have a typo in this this line, which will definitely cause a problem:

EndProc = GetFilteredRangeBotto[COLOR=#ff0000][B]n[/B][/COLOR]Row

VB will assume you will have a variable called GetFilteredRangeBottonRow, which will have a default value of zero, so EndProc will be given the value 0 and your loop won't in fact loop at all.

This is a classic example of why you should always use Option Explicit. On compile, VBA will then tell you that GetFilteredRangeBottonRow is not defined, i.e. identifying the typo and saving you a lot of time and grief.

There may be other problems with your code, so let us know how you go after making this correction.

 

[Hashiru]

Thanks StephenCrump. It works now perfect. I shall be using option Explicit from now on. What a massive time for such a mistake. Thank you.

 

[Hashiru]

Hi Everyone,

FoundRng not working properly.

here is the code:

        For k = 2 To NUM2 - 1
            Dim CriteriaStrg As Variant, DestRng As Range, FoundRng As Range
            Set CriteriaStrg = TempSh1.Cells(k, 7) ': Set FoundRng = TempSh1.Cells(1, 3)
            'TempSh1.Activate
            TempSh1.Range("$A$1:$E" & NUM2).AutoFilter Field:=1, Criteria1:=CriteriaStrg
            'TempSh.Activate
            TempSh.Range("$A$1:$I" & NUM1).AutoFilter Field:=1, Criteria1:=CriteriaStrg
            TempSh1.Activate
            StartProc = GetFilteredRangeTopRow
            EndProc = GetFilteredRangeBottomRow
            
                For L = 4 To 7
                        SourceStrg = TempSh1.Cells(L, 3) & " " & TempSh1.Cells(L, 4)
                        'EmpName = STD.Cells(R + 2, 4)
                        TempSh.Activate
                        With TempSh
                            On Error Resume Next
                                Set FoundRng = .Cells.Find(What:=SourceStrg, After:=.Cells(1, 1), LookIn:= _
                                xlFormulas, LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext).Activate
                            On Error GoTo 0
                            
                            If FoundRng Is Nothing Then
                                'RNum = .Cells(Rows.Count, 3).End(xlUp).Row + 1
                            ElseIf FoundRng > 1 Then
                                'RwNum = rFound.Row
                            End If
                        End With
                Next L
        Next k
End Sub

 

[StephenCrump]

It works now perfect. I shall be using option Explicit from now on.

That's good to hear, thanks.

 

[StephenCrump]

FoundRng not working properly.

Try without the .Activate

Set FoundRng = .Cells.Find(What:=SourceStrg, After:=.Cells(1, 1), LookIn:= _
    xlFormulas, LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext)[COLOR=#ff0000][B].Activate[/B][/COLOR]