VBA modification to skip all hidden rows

aldenes

New Member
Joined
Mar 2, 2020
Messages
7
Office Version
  1. 2019
Platform
  1. Windows
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:
VBA Code:
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:
VBA Code:
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
 
Last edited by a moderator:

Excel Facts

When did Power Query debut in Excel?
Although it was an add-in in Excel 2010 & Excel 2013, Power Query became a part of Excel in 2016, in Data, Get & Transform Data.
you can use this code to look for the hidden value of the row
VBA Code:
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

VBA Code:
Rows(XXXX).rowheight=0



so it could be something like this:
VBA Code:
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
VBA Code:
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
 
Upvote 0

Forum statistics

Threads
1,213,546
Messages
6,114,255
Members
448,556
Latest member
peterhess2002

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