VBA modification to skip all hidden rows

[aldenes]

Hello,

I have the following two different VBA that are running great. However, I am working with a very large data set and I need to hide rows in the source and have VBA ignore (skip) the hidden rows. If any of you bright minds could help me with that, it would be amazing! This is the last part of a large project and I cannot figure it out.
Thanks a million!

First VBA:

Sub ExamRequests()
   
' schedules Exam requests
   
    Set srcWS = Sheet2
    Set tarWS = Sheet3
   
    tot = tarWS.Range("ExamRequestCount")
    If tot > 0 Then
        cnt = 0
       
        With srcWS
            For i = 2 To .Cells(Rows.Count, 1).End(xlUp).row
                If cnt < tot Then
                    If InStr(1, .Cells(i, 12), "Exam Request") > 0 And .Cells(i, 18) = "" Then
                        .Cells(i, 1).EntireRow.Copy tarWS.Cells(Application.Max(10, tarWS.Cells(Rows.Count, 1).End(xlUp).Offset(1).row), 1)
                        .Cells(i, 1).EntireRow.Delete
                        i = i - 1
                        cnt = cnt + 1
                    End If
                Else
                    Exit For
                End If
            Next i
            If cnt < tot Then MsgBox "There were not enough Perio Treatments to fill the selected number of appointments.", , ""
        End With
    End If
End Sub

2nd VBA:

Sub OralSurgery()

' schedules oral surgery and restorative and concats any other existing entries

    Dim strName As String
Dim intQuad As Integer
Dim strQuad As String
Dim intCount As Integer
Dim lr As Long
Dim strX As String
Dim strPrevName As String, strCurrName As String
Dim srcWS As Worksheet
Dim tarWS As Worksheet
Dim tot As Long
Dim cnt As Long
Dim i As Long, j As Long

Set srcWS = Sheet2
Set tarWS = Sheet3

tot = tarWS.Range("OralSurgeryCount")

If tot > 0 Then
cnt = 0

With srcWS
lr = .Cells(Rows.Count, 1).End(xlUp).row

For i = 2 To lr
strCurrName = .Cells(i, "a")
If strCurrName <> strPrevName Then

If cnt < tot Then
If .Cells(i, "M") > 0 Then
                      

                            ' throws script error 1004 (out of range) when running.
If .Cells(i, "M") > 32 Then
' Either bad data or unintended conversion to a date value
' If this occurs then the rest of this section of code will get errors
' MsgBox "Unexpected Tooth Range value found in row " & i & ": " & .Cells(i, 13).Text


Else

strName = .Cells(i, 1)
Select Case .Cells(i, "M")
Case Is <= 8: intQuad = 23: strQuad = "UR"
Case Is <= 16: intQuad = 24: strQuad = "UL"
Case Is <= 24: intQuad = 25: strQuad = "LL"
Case Is <= 32: intQuad = 26: strQuad = "LR"
End Select

intCount = Application.CountIfs(.Columns(1), strName, .Columns(intQuad), "*?", .Columns(intQuad), strQuad)

If intCount > 1 Then
strX = .Cells(i, "M")
For j = i + 1 To lr
If .Cells(j, "A") = strName And .Cells(j, "M") > 0 And .Cells(j, intQuad) = strQuad Then
strX = strX & ", " & .Cells(j, "M")
.Rows(j).Delete
lr = lr - 1
End If
Next j
Else
strX = .Cells(i, "M")
End If


' Check if any treatment plan items exist already for this patient
If Application.WorksheetFunction.CountIfs(.Columns("A:A"), .Cells(i, "A"), .Columns("R:R"), "*?") = 0 Then
.Rows(i).Copy tarWS.Cells(Application.Max(10, tarWS.Cells(Rows.Count, "A").End(xlUp).Offset(1).row), 1)
.Cells(i, "A").EntireRow.Delete
tarWS.Cells(tarWS.Cells(Rows.Count, 1).End(xlUp).row, "AE") = strX
i = i - 1
cnt = cnt + 1
strPrevName = strCurrName
End If
End If
End If
Else
Exit For
End If
End If
Next i
If cnt < tot Then MsgBox "There were not enough OS / Restorative requests to fill the selected number of appointments.", , ""
End With
End If
End Sub

 

[Puertorekinsam]

you can use this code to look for the hidden value of the row

Rows(XXXX).EntireRow.Hidden

In this case I would also check the height of the row.. it shouldn't make a difference, but you never know. That code would be

Rows(XXXX).rowheight=0

so it could be something like this:

Sub ExamRequests(

' schedules Exam requests

    Set srcWS = Sheet2
    Set tarWS = Sheet3

    tot = tarWS.Range("ExamRequestCount")

    If tot > 0 Then

        cnt = 0

        With srcWS

            For i = 2 To .Cells(Rows.Count, 1).End(xlUp).Row
             If Rows(i).EntireRow.Hidden = False Or Rows(i).RowHeight = 0 Then
                If cnt < tot Then
                    If InStr(1, .Cells(i, 12), "Exam Request") > 0 And .Cells(i, 18) = "" Then
                        .Cells(i, 1).EntireRow.Copy tarWS.Cells(Application.Max(10, tarWS.Cells(Rows.Count, 1).End(xlUp).Offset(1).Row), 1)
                        .Cells(i, 1).EntireRow.Delete
                        i = i - 1
                        cnt = cnt + 1
                    End If
               Else
                    Exit For
                End If
            End If
            Next i
            If cnt < tot Then MsgBox "There were not enough Perio Treatments to fill the selected number of appointments.", , ""
        End With
    End If
End Sub

and

Sub OralSurgery()

' schedules oral surgery and restorative and concats any other existing entries

    Dim strName As String
Dim intQuad As Integer
Dim strQuad As String
Dim intCount As Integer
Dim lr As Long
Dim strX As String
Dim strPrevName As String, strCurrName As String
Dim srcWS As Worksheet
Dim tarWS As Worksheet
Dim tot As Long
Dim cnt As Long
Dim i As Long, j As Long

Set srcWS = Sheet2
Set tarWS = Sheet3

tot = tarWS.Range("OralSurgeryCount")

If tot > 0 Then
cnt = 0

With srcWS
lr = .Cells(Rows.Count, 1).End(xlUp).Row

For i = 2 To lr
If Rows(i).EntireRow.Hidden = True Or Rows(i).RowHeight = 0 Then
    
    strCurrName = .Cells(i, "a")
    If strCurrName <> strPrevName Then
    
    If cnt < tot Then
    If .Cells(i, "M") > 0 Then
                          
    
                                ' throws script error 1004 (out of range) when running.
    If .Cells(i, "M") > 32 Then
    ' Either bad data or unintended conversion to a date value
    ' If this occurs then the rest of this section of code will get errors
    ' MsgBox "Unexpected Tooth Range value found in row " & i & ": " & .Cells(i, 13).Text
    
    
    Else
    
    strName = .Cells(i, 1)
    Select Case .Cells(i, "M")
    Case Is <= 8: intQuad = 23: strQuad = "UR"
    Case Is <= 16: intQuad = 24: strQuad = "UL"
    Case Is <= 24: intQuad = 25: strQuad = "LL"
    Case Is <= 32: intQuad = 26: strQuad = "LR"
    End Select
    
    intCount = Application.CountIfs(.Columns(1), strName, .Columns(intQuad), "*?", .Columns(intQuad), strQuad)
    
    If intCount > 1 Then
    strX = .Cells(i, "M")
    For j = i + 1 To lr
    If .Cells(j, "A") = strName And .Cells(j, "M") > 0 And .Cells(j, intQuad) = strQuad Then
    strX = strX & ", " & .Cells(j, "M")
    .Rows(j).Delete
    lr = lr - 1
    End If
    Next j
    Else
    strX = .Cells(i, "M")
    End If
    
    
    ' Check if any treatment plan items exist already for this patient
    If Application.WorksheetFunction.CountIfs(.Columns("A:A"), .Cells(i, "A"), .Columns("R:R"), "*?") = 0 Then
    .Rows(i).Copy tarWS.Cells(Application.Max(10, tarWS.Cells(Rows.Count, "A").End(xlUp).Offset(1).Row), 1)
    .Cells(i, "A").EntireRow.Delete
    tarWS.Cells(tarWS.Cells(Rows.Count, 1).End(xlUp).Row, "AE") = strX
    i = i - 1
    cnt = cnt + 1
    strPrevName = strCurrName
    End If
    End If
    End If
    Else
    Exit For
    End If
    End If
    End If
    
Next i
If cnt < tot Then MsgBox "There were not enough OS / Restorative requests to fill the selected number of appointments.", , ""
End With
End If
End Sub

 

[aldenes]

That is awesome! Thank you very much!