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]

:help Request help in correcting the code to copy the ranges D4.:D10 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!