How to maintain a consolidated checklist for preparing dashboard

[anish.ms]

Dear Experts,
Request your advice on how better the attached store visit/audit checklist can be maintained consolidated for all the visits. There are total of 2and 00 stores and each store will be revisited once a quarter. And the consolidated sheet will be used to develop a dashboard which will show the history of each store's compliance and manager wise compliance. etc.TH
thanks in advance

[Aussiebear]

Now I recognise that I'm a Neanderthal with Mathematics. Some of my best sleeps were during maths periods at school but can someone tell me which year it was introduced where a description of "2 and 00" was the subject material of the teacher? I'm still getting over the fact that 1 + 1 <> 3.

BTW: I have also got a phobia on Clipboard warriors, so maybe I should let others answer this query.

[anish.ms]

Hi Aussiebear,
It was a typo error, please read as 200 stores

[anish.ms]

Request help in correcting the code to copy the ranges D4.10 and O13:085 from sheet "Visit Report" to the table in sheet "Database". There are 2 cells (O35 and O65) to be ignored from copying as they don't have any data.
I tried the following code, but it is not working properly

Sub Button_Click()
 Dim arr As Variant
 arr = ThisWorkbook.Worksheets("Visit Report").Range("D4:D10", "O13:O85")
 With ThisWorkbook.Worksheets("Database").ListObjects(1)
.ListRows.Add.Range.Resize(LBound(arr, 1), UBound(arr, 1)).Value = arr
 End With
End Sub

thanks in advance

[Paul_Hossler]

Option Explicit


Sub Button_Click()
    Dim arr1 As Variant, arr2 As Variant
 
    With ThisWorkbook.Worksheets("Visit Report")
        arr1 = Application.WorksheetFunction.Transpose(.Range("D4:D10"))
        arr2 = Application.WorksheetFunction.Transpose(.Range("O13:O85"))
    End With
    
    With ThisWorkbook.Worksheets("Database").ListObjects(1)
        .ListRows.Add.Range.Resize(1, UBound(arr1, 1)).Value = arr1
        .ListRows(.ListRows.Count).Range.Cells(8).Resize(1, UBound(arr2)).Value = arr2
    End With
End Sub

[anish.ms]

Thanks a lot Paul!
You are always my superhero
Also, I need to have the option of loading the information back to the visit report from the database, which may be from a drop-down list. Let me try that out and will definitely have to come back to seek your help.

[Paul_Hossler]

Also, I need to have the option of loading the information back to the visit report from the database, which may be from a drop-down list. Let me try that out and will definitely have to come back to seek your help.

1. I made some improvements to the sub to copy to database

2. I'd check out double clicking a cell in a row on Database, and moving that data to the input form

Option Explicit


Sub Button_Click()
    Dim wsVR As Worksheet
    Dim loDB As ListObject
    Dim arr As Variant
    Dim n As Long
 
    Set wsVR = ThisWorkbook.Worksheets("Visit Report")
    Set loDB = ThisWorkbook.Worksheets("Database").ListObjects(1)
        
        
    arr = Application.WorksheetFunction.Transpose(wsVR.Range("D4:D10"))
    loDB.ListRows.Add.Range.Resize(1, UBound(arr, 1)).Value = arr
    n = loDB.ListRows.Count
        
    arr = Application.WorksheetFunction.Transpose(wsVR.Range("O13:O34"))
    loDB.ListRows(n).Range.Cells(8).Resize(1, UBound(arr)).Value = arr
        
    arr = Application.WorksheetFunction.Transpose(wsVR.Range("O36:O65"))
    loDB.ListRows(n).Range.Cells(30).Resize(1, UBound(arr)).Value = arr
        
    arr = Application.WorksheetFunction.Transpose(wsVR.Range("O67:O85"))
    loDB.ListRows(n).Range.Cells(60).Resize(1, UBound(arr)).Value = arr
End Sub

Option Explicit


Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
    Dim wsVR As Worksheet
    Dim r As Range
    
    Set r = Target.Cells(1, 1).EntireRow
    
    If Len(r.Cells(1, 1).Value) = 0 Then Exit Sub
    
    Set wsVR = ThisWorkbook.Worksheets("Visit Report")
    
    r.Cells(1, 1).Resize(1, 7).Copy
    wsVR.Range("D4").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=True
    
    r.Cells(1, 8).Resize(1, 22).Copy
    wsVR.Range("O13").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=True
    
    r.Cells(1, 30).Resize(1, 30).Copy
    wsVR.Range("O36").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=True
    
    r.Cells(1, 60).Resize(1, 19).Copy
    wsVR.Range("O67").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=True
    
    Application.CutCopyMode = False
End Sub

[anish.ms]

Thanks a ton Paul!. Really appreciate your help.
Is it possible to replace the saved data instead of adding a new line on the button click if it is loaded from the database?

[Paul_Hossler]

There's probably a better (i.e. more ListObject) way of doing this, but I'm not very good with ListObjects

Option Explicit


Sub Button_Click()
    Dim wsVR As Worksheet
    Dim loDB As ListObject
    Dim arr As Variant
    Dim n As Long, r As Long
 
    Set wsVR = ThisWorkbook.Worksheets("Visit Report")
    Set loDB = ThisWorkbook.Worksheets("Database").ListObjects(1)
        
    r = 0
    On Error Resume Next
    r = Application.WorksheetFunction.Match(wsVR.Range("D4").Value, loDB.DataBodyRange.Columns(1), 0)
    On Error GoTo 0
    
    If r = 0 Then       '   not in data base
        arr = Application.WorksheetFunction.Transpose(wsVR.Range("D4:D10"))
        loDB.ListRows.Add.Range.Resize(1, UBound(arr, 1)).Value = arr
        n = loDB.ListRows.Count
    
    Else
        arr = Application.WorksheetFunction.Transpose(wsVR.Range("D4:D10"))
        loDB.ListRows(r).Range.Resize(1, UBound(arr)).Value = arr
        n = r
    End If
        
    arr = Application.WorksheetFunction.Transpose(wsVR.Range("O13:O34"))
    loDB.ListRows(n).Range.Cells(8).Resize(1, UBound(arr)).Value = arr
        
    arr = Application.WorksheetFunction.Transpose(wsVR.Range("O36:O65"))
    loDB.ListRows(n).Range.Cells(30).Resize(1, UBound(arr)).Value = arr
        
    arr = Application.WorksheetFunction.Transpose(wsVR.Range("O67:O85"))
    loDB.ListRows(n).Range.Cells(60).Resize(1, UBound(arr)).Value = arr
    
    MsgBox wsVR.Range("D4").Value & " added / updated"
    
End Sub

[anish.ms]

Thanks Paul!
Can I merge the store name and date to see whether data exists? because the same store can be visited again at a later date. I tried the following code but it's not working.
I think the problem is with merging table columns 1 and 7

    r = Application.WorksheetFunction.Match(wsVR.Range("D4").Value & wsVR.Range("D10").Value, _
    loDB.DataBodyRange.Columns(1) & loDB.DataBodyRange.Columns(7), 0)

[Paul_Hossler]

What makes a row unique?

STORE + DATE?

So

1. STORE1 on 7/22/2022 doesn't exist so all its data gets added to Row 10

2. STORE1 on 7/25/2022 doesn't exist so all its datat gets added to Row 11

3. STORE1 on 7/22/2022 DOES exist so the new data gets updated on Row 10

[anish.ms]

Yes exactly store + date makes the data unique

[Paul_Hossler]

Well, you can try something like this

Option Explicit


Sub Button_Click()
    Dim wsVR As Worksheet
    Dim loDB As ListObject
    Dim arr As Variant
    Dim n As Long, r As Long, vis As Long
 
    Set wsVR = ThisWorkbook.Worksheets("Visit Report")
    Set loDB = ThisWorkbook.Worksheets("Database").ListObjects(1)
        
    With loDB
        .Range.AutoFilter Field:=2
        .Range.AutoFilter Field:=7
    
        .Range.AutoFilter Field:=2, Criteria1:=wsVR.Range("D5").Value
        .Range.AutoFilter Field:=7, Criteria1:=wsVR.Range("D10").Value
    
        vis = .Range.Columns(2).SpecialCells(xlCellTypeVisible).Count
    
    End With
    
        Select Case vis
    
        Case 1      '   only header row so just add
            arr = Application.WorksheetFunction.Transpose(wsVR.Range("D4:D10"))
            loDB.ListRows.Add.Range.Resize(1, UBound(arr, 1)).Value = arr
            n = loDB.ListRows.Count
        
            arr = Application.WorksheetFunction.Transpose(wsVR.Range("O13:O34"))
            loDB.ListRows(n).Range.Cells(8).Resize(1, UBound(arr)).Value = arr
                
            arr = Application.WorksheetFunction.Transpose(wsVR.Range("O36:O65"))
            loDB.ListRows(n).Range.Cells(30).Resize(1, UBound(arr)).Value = arr
                
            arr = Application.WorksheetFunction.Transpose(wsVR.Range("O67:O85"))
            loDB.ListRows(n).Range.Cells(60).Resize(1, UBound(arr)).Value = arr
            
            loDB.Range.AutoFilter Field:=2
            loDB.Range.AutoFilter Field:=7
            
            MsgBox wsVR.Range("D5").Value & " on " & wsVR.Range("D10") & " added"
        
        Case 2      '   header plus one store/date row so just update
            If loDB.Range.Columns(2).SpecialCells(xlCellTypeVisible).Areas.Count = 1 Then       '   header and row 2
                n = 2
            Else
                n = loDB.Range.Columns(2).SpecialCells(xlCellTypeVisible).Areas(2).Row
            End If
            
            arr = Application.WorksheetFunction.Transpose(wsVR.Range("D4:D10"))
            loDB.Parent.Cells(n, 1).Resize(1, UBound(arr)).Value = arr
        
            arr = Application.WorksheetFunction.Transpose(wsVR.Range("O13:O34"))
            loDB.Parent.Cells(n, 8).Resize(1, UBound(arr)).Value = arr
                
            arr = Application.WorksheetFunction.Transpose(wsVR.Range("O36:O65"))
            loDB.Parent.Cells(n, 30).Resize(1, UBound(arr)).Value = arr
                
            arr = Application.WorksheetFunction.Transpose(wsVR.Range("O67:O85"))
            loDB.Parent.Cells(n, 60).Resize(1, UBound(arr)).Value = arr
            
            loDB.Range.AutoFilter Field:=2
            loDB.Range.AutoFilter Field:=7
            
            MsgBox wsVR.Range("D5").Value & " on " & wsVR.Range("D10") & " updated"
        
        Case Else
            MsgBox "There are " & vis - 1 & " entries for " & wsVR.Range("D5").Value & " -- " & wsVR.Range("D10").Value
        
        End Select
    
End Sub

[anish.ms]

Thanks Paul!
The same entry got added once more from my pc, which may be due to the regional date settings. But when I changed the date format from "dd/mm/yyyy" to "dd/mmm/yyyy", the entries got added multiple times instead of updating. I also noticed one thing when I deleted all the data from the database and then when I saved a new entry, till column 7 it got saved in the 2nd row and from column 8 onwards in the 3rd row. Subsequent entries were getting saved in the same row.

[Paul_Hossler]

I was overly complicating some things

try this version

Option Explicit


Sub Button_Click()
    Dim wsVR As Worksheet
    Dim loDB As ListObject
    Dim arr As Variant
    Dim n As Long, r As Long
 
    Set wsVR = ThisWorkbook.Worksheets("Visit Report")
    Set loDB = ThisWorkbook.Worksheets("Database").ListObjects(1)
        
    n = 0
        
    With loDB
        For r = 1 To .ListRows.Count
            If .ListRows(r).Range.Cells(1, 2).Value <> wsVR.Range("D5").Value Then GoTo NextRow     '   not store
            If .ListRows(r).Range.Cells(1, 7).Value <> wsVR.Range("D10").Value Then GoTo NextRow    '   not date
        
            n = r
                        
            Exit For
NextRow:
        Next r
        
        If n = 0 Then
            loDB.ListRows.Add        '   add new row
            r = .ListRows.Count
        End If
        
        arr = Application.WorksheetFunction.Transpose(wsVR.Range("D4:D10"))
        .ListRows(r).Range.Cells(1).Resize(1, UBound(arr)).Value = arr
    
        arr = Application.WorksheetFunction.Transpose(wsVR.Range("O13:O34"))
        .ListRows(r).Range.Cells(8).Resize(1, UBound(arr)).Value = arr
            
        arr = Application.WorksheetFunction.Transpose(wsVR.Range("O36:O65"))
        .ListRows(r).Range.Cells(30).Resize(1, UBound(arr)).Value = arr
            
        arr = Application.WorksheetFunction.Transpose(wsVR.Range("O67:O85"))
        .ListRows(r).Range.Cells(60).Resize(1, UBound(arr)).Value = arr
    
    End With


End Sub

[anish.ms]

Thanks a lot Paul!

[anish.ms]

Hi Paul,

I have moved the database to a different workbook and then when I double-click on any item in the database to load the entries into the workbook(visit checklist) the screen updating is on

I have used Application.ScreenUpdating = False in the macro
How can I turn off ScreenUpdating in the other workbook

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)


    Dim wsVR   As Worksheet
    Dim r      As Range


    Set r = Target.Cells(1, 1).EntireRow
    
    If Len(r.Cells(1, 1).Value) = 0 Then Exit Sub
    
    Set wsVR = Workbooks("LP Checklist V2.2.xlsm").Worksheets("Visit Checklist")
    
    With Application
        .ScreenUpdating = False
        .EnableEvents = False
        .Calculation = xlCalculationManual
        .DisplayAlerts = False
    End With
    
    r.Cells(1, 1).Resize(1, 4).Copy               'Store info
    wsVR.Range("D4").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=True
    
    r.Cells(1, 5).Resize(1, 3).Copy
    wsVR.Range("G5").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=True
    
    r.Cells(1, 8).Resize(1, 23).Copy              'Answer
    wsVR.Range("K11").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=True
    
    r.Cells(1, 31).Resize(1, 30).Copy
    wsVR.Range("K35").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=True
    
    r.Cells(1, 61).Resize(1, 19).Copy
    wsVR.Range("K66").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=True
    
    Application.CutCopyMode = False
    
    With Application
        .ScreenUpdating = True
        .EnableEvents = True
        .Calculation = xlCalculationAutomatic
        .DisplayAlerts = True
    End With
    
    Application.GoTo wsVR.Range("D4")
    
End Sub

[anish.ms]

I used wsVR.Activate before Application.ScreenUpdating = False and the screen updating is off now
Thanks!