Problem With Scrolling Data Through A Static Display Range

[Ark68]

I have found myself well outside my novice understanding of VBA. I am working on a pretty significant project and have adopted a concept that has brought with it a series of hurdles as I move forward. I hope someone here can appreciate that explaining the problem may be as much of an issue in seeking help than the actual problem, so please, be patient with my explanation. If anyone feels they could help, but my explanation isn't clear, or critical information is needed, please ask and I'll do my best. As much as I wish I could share the workbook, because my project relies of a number of seperate workbooks, it wouldn't be necessarily practical to share the project. The databases contain sensitive information, and would take a long time to edit, and such edits would affect the functionality of the project and create even more frustration with errors.

I have a worksheet (ws_gui1) with a defined and static range (B6:AM40) to display rows of dynamic data extracted from a secondary filtered database (a second workbook). The number of rows that can be extracted from the data can be any number (dynamic). But, my display limits the amount of visible rows of data to only 35 rows at a time. When the amount of extracted rows is 35 rows or less, my processes work great! To overcome the visible limit, I have adopted a more complex process of adding a scroll bar to that static data area. This has allowed me to view all rows in excess of 35 in that static display area by using a scrollbar.

Please try to follow my code:
To initiate the transfer of data between the data workbook the user presses a [SUBMIT] button which launches this code:

Sub GUI_S_Submit1()
    
    Dim objFS As Object
    Dim objFile As Object
    Dim vFile As Variant
    Dim rngData As Range
    Dim ar_eventtype As Variant
    Dim ar_feetype As Variant
    Dim ar_cntevente As Variant
    Dim ar_cntfee As Variant
    
    mbevents = False

    With ws_gui1 'the worksheet displaying the data in the static range of B6:AM40
        page = 2
        .Unprotect

        'how many records match the queried date in the master DB
        cnt_qdatebk = Application.WorksheetFunction.CountIf(wb_rmr.Worksheets("CORE_DATA").Range("A:A"), n_date)  'source data base is wb_rmr sheet "CORE_DATA". n_date is a publicly declared variable
        
        If cnt_qdatebk = 0 Then
            MsgBox "No bookings exist in this current reservation report." & Chr(13) & "Please select another date, or prepare another report for this date.", vbCritical, "NO DATA : " & Format(n_date, "dddd dd-mmm-yy")
            Start1 'resets ws_gui1
            Exit Sub
        End If
        .Range("AR10") = cnt_qdatebk
        
        'how many records match the queried date in the master DB
        cnt_qdatefee = Application.WorksheetFunction.CountIf(wb_pbef.Worksheets("FEE_DATA").Range("G:G"), n_date)
        .Range("AV10") = cnt_qdatefee
        
        'copy PBEF data to RMR and close
        Application.ScreenUpdating = False
        Windows(wb_rmr.Name).Visible = True
        wb_pbef.Worksheets("FEE_DATA").Copy After:=wb_rmr.Worksheets("CORE_DATA")
        wb_pbef.Close savechanges:=False
        Windows(wb_rmr.Name).Visible = False
        Application.ScreenUpdating = True
        'MsgBox "PBEF closed. No changes."
        
        'add support sheets to RMR
        With wb_rmr
            .Sheets.Add(After:=.Sheets(.Sheets.Count)).Name = "STAFF"
            .Sheets.Add(After:=.Sheets(.Sheets.Count)).Name = "ROUTINE"
            .Sheets.Add(After:=.Sheets(.Sheets.Count)).Name = "T_HOLD"
        End With
        
        'save RMR under new core data name
        st_cd = "CD_" & Format(n_date, "ddd dd-mmm-yy")
        wb_rmr.SaveAs Filename:="D:\WSOP 2020\Data\" & st_cd & ".xlsx"

        'set CORE DATA worksheet alias
        Set wb_rmr = Workbooks(st_cd & ".xlsx")
        Set ws_cd1 = wb_rmr.Worksheets("CORE_DATA")
        Set ws_stf1 = wb_rmr.Worksheets("STAFF")
        Set ws_th = wb_rmr.Worksheets("T_HOLD")
        Set ws_rtn1 = wb_rmr.Worksheets("ROUTINE")
        Set ws_fd1 = wb_rmr.Worksheets("FEE_DATA")
        
        'filter worksheets
'Stop
        With ws_cd1
            cnt_date = Application.WorksheetFunction.CountIf(.Columns(1), n_date)
            cnt_rows = Application.WorksheetFunction.Count(.Columns(1))
            rte = cnt_rows - cnt_date
            
            'unprotect core data
            .Unprotect
                       
            'filter core data of all dates not equal to queried date
            .Range("A1").AutoFilter Field:=1, Criteria1:="<>" & n_date
            
            'eliminate extra dates
            .Range("A2:A" & cnt_rows + 1).SpecialCells(xlCellTypeVisible).EntireRow.Delete
            .AutoFilterMode = False

            'what rows of data remain will be presented in the static area of ws_gui1
            
            'insert time fields
            .Columns(3).Insert
            .Cells(1, 3) = "Start"
            .Cells(1, 4) = "End"
            
            'populate time fields
            For r = 2 To .Cells(.Rows.Count, "A").End(xlUp).Row
                .Cells(r, 3) = Format(TimeValue(Left(.Cells(r, 5), 8)), "h:mm AM/PM")
                .Cells(r, 4) = Format(TimeValue(Right(.Cells(r, 5), 8)), "h:mm AM/PM")
            Next r
            
            .Range("C2:D" & .Cells(.Rows.Count, "A").End(xlUp).Row).Copy
            .Range("C2").PasteSpecial Paste:=xlPasteAll
            
            'delete redundant columns
            .Columns(5).EntireColumn.Delete
            .Range("J:K,P:T,W:W").EntireColumn.Delete
            
            'insert rcode (DR, DT, FR ...) column
            .Columns(12).Insert
            .Cells(1, 12).Value = "RCode"
            
            Dim strFile As String
            Dim fname As String

            fname = "permit_info.xlsm"
            strFile = "D:\WSOP 2020\" & fname
            If Not FileExists(strFile) Then
                MsgBox "A critical application file is missing." & Chr(13) & "Unable to continue process.", vbCritical, "CRITICAL ERROR: permit_info.xlsm"
                Stop
            End If
            xRet = IsWorkBookOpen(fname)
            If Not xRet Then
                Workbooks.Open strFile
                'when permit_info.xlsm file open, the 'form' is reset in the background
                Workbooks(fname).Windows(1).Visible = False
            End If
            Set wb_permit = Workbooks("permit_info.xlsm")
            Set ws_pdata = wb_permit.Worksheets("permit_data")

            lr_cd1 = .Cells(.Rows.Count, "B").End(xlUp).Row
            For r = 2 To lr_cd1
                pn = .Cells(r, 11).Value
                On Error Resume Next
                .Cells(r, 12) = Application.WorksheetFunction.VLookup(pn, ws_pdata.Range("A:B"), 2, False)
            Next r
        End With
        
        With ws_fd1
            cnt_date = Application.WorksheetFunction.CountIf(.Columns(7), n_date)
            cnt_rows = Application.WorksheetFunction.Count(.Columns(7))
            rte = cnt_rows - cnt_date
            
            'unprotect extra fees
            .Unprotect
            With ws_gui1.Range("AU3")
                .Value = "EXTRA FEES   " & Chr(208) 'unlocked
                .Font.Name = "Arial Narrow"
                .Characters(Len(.Value), 1).Font.Name = "Webdings"
            End With
            
            'filter core data of all dates not equal to queried date
            .Range("A1").AutoFilter Field:=7, Criteria1:="<>" & n_date
            test = Application.WorksheetFunction.Subtotal(2, .Columns(7))
            
            'eliminate extra dates
            .Range("A2:A" & cnt_rows + 1).SpecialCells(xlCellTypeVisible).EntireRow.Delete
            .AutoFilterMode = False
            
        End With
        
        'count type from Core Data
        cnt_eventtype

        'count type from Fee Data
        Set wb_pbef = Workbooks(st_cd & ".xlsx") 'alias change so that common cnt_feetype macro can run
        cnt_feetype

        'array definitions
        ar_eventtype = Array("Ball Diamonds:", "Outdoor Fields:", "Beach Volleyball:", "Picnics:", "Special Events:", "Festivals:", "Passive Park:", "Administration:", "Maintenance:", "Unassigned:")
        ar_cntevent = Array(cnt_dia, cnt_of, cnt_bv, cnt_pic, cnt_se, cnt_fest, cnt_psvpk, cnt_admn, cnt_mtn, cnt_noa)
        ar_feetype = Array("Dia. Lights BP:", "Dia. Lights HP:", "Dia. Lights RP:", "Dia. Lights WP:", "Dia. Configuration:", "Dia. Lining:", "Fld. Lights BP:", "Fld. Lights RP:", "Fld. Lights WSP:", "Fld. Configuration:", "Fld. Lining:", "Unknown:")
        ar_cntfee = Array(cnt_dlbp, cnt_dlhp, cnt_dlrp, cnt_dlwp, cnt_dc, cnt_dl, cnt_flbp, cnt_flrp, cnt_flwsp, cnt_fc, cnt_fl, cnt_nob)
        
        'populate RID column
        RID1

        DPOP1 'this routine populates the static data range of ws_gui1
        
        wb_rmr.Save
        .Range("AX2") = Format(Now, "h:mm:ss")
        secure
        .Protect
        mbevents = True
        .Range("G43").Select 'neutral
    
    End With
End Sub

DPOP1 below is code that takes the filtered data from the source datasheet (ws_cd1) and applies it to the static data range in ws_gui1

Sub DPOP1() 'initial GUI data range population of core data greater than 35 records (scroll bar required)

    With ws_gui1

        If ws_cd1.AutoFilterMode Then ws_cd1.AutoFilterMode = False
        cd1cnt_rows = Application.WorksheetFunction.Count(ws_cd1.Columns(1))
        drows = cd1cnt_rows + 1
       
        'source data contains more than 35 rows of data - scrollbar required
        If cd1cnt_rows > 35 Then '35 rows is the max amount of data that can be viewed without needing the scroll bar
            mxds = cd1cnt_rows - (35 - 1) 
            With datascroll 'datascoll is publicaly declared as an object
                .Visible = True
                .Value = 0
                .Min = 1
                .Max = mxds
                .SmallChange = 1
                .LargeChange = 35 
                .LinkedCell = "Sandbox!$D$1"
                .Display3DShading = True
             End With
            ' the static display range is populated with formulae. I find this complicated.
            .Range("B6:B40").Formula = "=INDEX('[" & wb_pbef.Name & "]CORE_DATA'!A2:$A$" & drows & ",Sandbox!$D$1)"
            .Range("C6:C40").Formula = "=INDEX('[" & wb_pbef.Name & "]CORE_DATA'!L2:$L$" & drows & ",Sandbox!$D$1)"
            .Range("D6:D40").Formula = "=INDEX('[" & wb_pbef.Name & "]CORE_DATA'!M2:$M$" & drows & ",Sandbox!$D$1)&"""""
            .Range("E6:E40").Formula = "=INDEX('[" & wb_pbef.Name & "]CORE_DATA'!D2:$D$" & drows & ",Sandbox!$D$1)"
            .Range("F6:F40").Formula = "=INDEX('[" & wb_pbef.Name & "]CORE_DATA'!E2:$E$" & drows & ",Sandbox!$D$1)"
            .Range("G6:G40").Formula = "=INDEX('[" & wb_pbef.Name & "]CORE_DATA'!I2:$I$" & drows & ",Sandbox!$D$1)"
            .Range("L6:L40").Formula = "=INDEX('[" & wb_pbef.Name & "]CORE_DATA'!J2:$J$" & drows & ",Sandbox!$D$1)"
            .Range("V6:V40").Formula = "=INDEX('[" & wb_pbef.Name & "]CORE_DATA'!F2:$F$" & drows & ",Sandbox!$D$1)"
            .Range("AL6:AL40").Formula = "=INDEX('[" & wb_pbef.Name & "]CORE_DATA'!G2:$G$" & drows & ",Sandbox!$D$1)"
                 
        '35 or less rows of source data will fit into static display area without needing a scrollbar.
        Else
            With datascroll
                .Visible = False
            End With
            DPOP2 
        End If

       'assess permits to determine which are in permit file and those not
        CHK_PERMIT 
    
    End With
End Sub

Here is DPOP2 fro reference. Unlike DPOP1, it is just a simple cut and paste of data to the destination.

Sub DPOP2() 'initial GUI data range population of core data less than or equal to 35 (scroll bar not required)
    With ws_gui1
        With .Range("B6:AM40")
            .ClearContents
            .Cells.Font.Color = vbBlack
            .Interior.ColorIndex = 0
        End With
        'lwr_row = (page - 1) * 35 + 1
        'upr_row = lwr_row + 35
        act_rows = Application.WorksheetFunction.Count(ws_cd1.Range("B:B"))
    'rid transfer
        ws_cd1.Range("A2:A" & act_rows + 1).Copy
        .Range("B6").PasteSpecial Paste:=xlPasteValues
    'permit transfer
        ws_cd1.Range("L2:L" & act_rows + 1).Copy
        .Range("C6").PasteSpecial Paste:=xlPasteValues
    'rcode transfer
        ws_cd1.Range("M2:M" & act_rows + 1).Copy
        .Range("D6").PasteSpecial Paste:=xlPasteValues
    'times transfer
        ws_cd1.Range("D2:E" & act_rows + 1).Copy
        .Range("E6").PasteSpecial Paste:=xlPasteValues
    'event transfer
        For m = 6 To 40
            .Range("G" & m & ":K" & m).UnMerge
        Next m
        ws_cd1.Range("I2:I" & act_rows + 1).Copy
        .Range("G6").PasteSpecial Paste:=xlPasteValues
        For m = 6 To 40
           .Range("G" & m & ":K" & m).Merge
           .Range("G" & m & ":K" & m).HorizontalAlignment = xlLeft
        Next m
    'event type transfer
        For m = 6 To 40
            .Range("L" & m & ":U" & m).UnMerge
        Next m
        ws_cd1.Range("J2:J" & act_rows + 1).Copy
        .Range("L6").PasteSpecial Paste:=xlPasteValues
        For m = 6 To 40
            .Range("L" & m & ":U" & m).Merge
            .Range("L" & m & ":U" & m).HorizontalAlignment = xlCenter
        Next m
    'Next m
    'facility transfer
        For m = 6 To 40
            .Range("V" & m & ":AK" & m).UnMerge
        Next m
        ws_cd1.Range("F2:F" & act_rows + 1).Copy
        .Range("V6").PasteSpecial Paste:=xlPasteValues
        For m = 6 To 40
            .Range("V" & m & ":AK" & m).Merge
            .Range("V" & m & ":AK" & m).HorizontalAlignment = xlLeft
        Next m
    ' type transfer
        ws_cd1.Range("G2:G" & act_rows + 1).Copy
        .Range("AL6").PasteSpecial Paste:=xlPasteValues
    End With
'Stop
End Sub

This is where I am starting to run into problems. Following the population of data to the static display range on ws_gui1, the next step is to execute CHK_PERMIT. CHK_PERMIT is code that is supposed to cross reference the value in column B of the static data with data in a third (permit) database. If there is no match in the permit database to the value being queried from column B, that cell is formatted to provide a visual cue to the user that that particular value in B does not exist in the permit database. From there, the user can double click that cell the initiate a process to enter data to the permit database.

Sub CHK_PERMIT()
    With ws_gui1
            
        lrow = .Cells(.Rows.Count, "C").End(xlUp).Row
        ws_sand.Range("A:B").Clear

        For r = 6 To lrow
            pn = .Cells(r, 3) 'permit number
            pe = Application.WorksheetFunction.CountIf(ws_pdata.Columns(1), pn) 'check if in permit file
            If pe = 0 Then 'permit not in file
                .Cells(r, 3).Interior.Color = RGB(203, 67, 53)
                .Cells(r, 3).Font.Color = vbWhite
                If Application.WorksheetFunction.CountIf(ws_sand.Columns(1), pn) = 0 Then 'check if in permit in hold
                    lsbprow = ws_sand.Cells(ws_sand.Rows.Count, "A").End(xlUp).Row + 1
                    ws_sand.Cells(lsbprow, 1) = pn
                    ws_sand.Cells(lsbprow, 2) = 1
                Else
                    trow = Application.WorksheetFunction.Match(pn, ws_sand.Columns(1), 0)
                    ws_sand.Cells(trow, 2) = ws_sand.Cells(trow, 2).Value + 1
                End If
            End If
        Next r
    
    If msgt <> 1 Then
        If Application.Sum(ws_sand.Columns(2)) = 1 Then
            MsgBox "There is one record with no permit information on file." & Chr(13) & "Double click on the red highlighted permits to submit permit information to file.", vbCritical, "CRITICAL INFO MISSING : Permit Info"
            Exit Sub
        End If
        If Application.Sum(ws_sand.Columns(2)) > 1 Then
            MsgBox "There are " & Application.Sum(ws_sand.Columns(2)) & " records with no permit information on file." & Chr(13) & "Double click on the red highlighted permits to submit permit information to file.", vbCritical, "CRITICAL INFO MISSING : Permit Info"
            Exit Sub
        End If
        MsgBox "No missing permit information Exists"
    End If
End Sub

When there is 35 rows or less of data, this is quite accurate. However, when there is more than 35, the first thirty five records display, but when scrolled, the new scrolled values retain any cell formatting indicating that those rows do not having a matching value in the permit database, which may be a false report. The formatting of the cell remains based on the initial value, and doesn't update with the new data as it's scrolled. I suspect I need to use a formula in DPOP1 to populate the cells in column C as the data in column B changes? But I have no idea how to do that?

 

[Ark68]

Perhaps conditional formatting for cells B6:B40?
If my vba for this is:

 pe = Application.WorksheetFunction.CountIf(ws_pdata.Columns(1), pn) 'check if in permit file
            If pe = 0 Then 'permit not in file
            ....format this cell

What would I put into the rule description ("Format values where this formula is true")?

 

[Ark68]

Hi all, is conditional formatting possible in this scenario?

 

[Ark68]

I have entered this formula in the rule description ...

=if(countif([permit_info.xlsm]Permit_Data!$A:$A,$C$15)) = 0

But I am getting an error that there is a problem with my formual, but don't know what.

 

[Ark68]

I have reached out to another audience for support.
Cross posted here.

Thanks.

 

[Ark68]

I think conditional formatting of the cells that get formatted (C6:C40) when a permit doesn't exist is possibly the way to go. However,I have discovered that I am unable to reference external workbooks in conditional formula.
On the gui worksheet I added a column (AO) that holds a formula that referencing the data worksheet to see if the value in column C of that row.

=COUNTIF([permit_info.xlsm]Permit_Data!$A:$A,C6) = 0

It returns a value of true (if the permit info exists in the database) or false (if it doesn't). When false is returned, the cell in column c of that row is formatted.
I have set up conditional formatting for the display range (C6:C40)
"Format values where this formula is true: =$A06=TRUE"

This works wonderfully when there is no scrolling. Those cells with permits that exist are not formatted, and those that don't (AO = FALSE) are.

However, when I scroll, I seem to lose the accuracy of the conditional formatting. For example, refer to RID 44040025 and 44040026. It reflects an accurate format. When I scroll, this is what happens to the formatting with thos same RIDS.

The RIDs have a hydrid formatting, a paler red. Their values in coloumn AO did not change, they are still FALSE, so I would expect that the conditional formatting rule would still kick in appropriately.

I hope this thread is still being monitored (I mustn't start a new one) and that their is an easy explanation and resolution. This has become a big hurdle. I think it might have something to do with my conditional format rule. Regardless of the cell I click on in C6:C40 to check the conditional formatting rule, the formula $AO6=TRUE exists, even if I'm not on row 6. But that doesn't explain why it's correct before scrolling.