.
The password for all presently is set to pw. This can be changed in the code, which requires you to search all macros.
Hopefully it is understood that you will need to enter all information regarding the Store IDs and addresses on Sheet 1.
Each new store entered must have the store line, then the five rating categories immediately below, then a blank line.
Any other layout of the stores / ratings will skew the workings of the macros.
The user will double-click the row (Sheet 1), left of the store number, to select each store. Once all the stores have
been selected, the user then clicks OK. They will have an opportunity to cancel progress at this point or continue.
Once they choose to continue, Sheet 1 is hidden and they cannot go back to change anything.
Sheet 2 is visible with the selected stores and the five rating categories to choose from. When all
ratings have been noted by double-clicking, they click OK. This reduces all rows to only the store ID and the rating
given by the user.
A message box then appears to request the workbook be emailed back to the sender, all changes to the workbook are saved,
and the workbook is protected and closed.
When you receive the workbook, it will open to Sheet 2. If you click on UNLOCK, the password request will show. Entering
the correct password unlocks the workbook and displays all sheets for your review.
If you want to reuse the workbook, on Sheet 1 clear all checkmarks in Col A. On Sheet 2 delete all rows from Row
#2 and down.
Hide Sheet 2 and the workbook is ready to go again.
Or you can simply keep a 'clean version' of the workbook and email that to the next customer.
NOTE: ALWAYS maintain a clean, unused copy of the workbook as a backup. Inevitably, something will occur that will damage or
corrupt a workbook. The clean, unused version can be copied as a working version.
Code:
Option Explicit
Sub AreYouSure()
Dim answer As Variant
answer = MsgBox("Are you sure? Once you click YES you may not return to this sheet.", vbYesNo + vbQuestion, "NO RETURN !")
If answer = vbYes Then
copyrange
Else
Exit Sub
End If
End Sub
Sub RowsVisi()
Dim a As Integer
Dim Last As Integer
Dim emptyRow As Integer
Application.ScreenUpdating = False
Last = Sheet1.Range("C" & Rows.Count).End(xlUp).Row
For emptyRow = 4 To Last Step 7
Sheet1.Range(Cells(emptyRow, "A"), Cells(emptyRow, "A")).Value = ChrW(&H2713)
Next emptyRow
For a = 4 To 500
If Worksheets("Sheet1").Cells(a, 1).Value = ChrW(&H2713) Then
Cells(a, 1).Select
Range(ActiveCell.Offset(0, 0), ActiveCell.Offset(6, 3)).Select
Selection.EntireRow.Hidden = False
End If
Next
Sheet1.Range("F1").Select
Application.ScreenUpdating = True
End Sub
Sub RowsNoVisi()
Dim a As Integer
Application.ScreenUpdating = False
For a = 4 To 500
If Worksheets("Sheet1").Cells(a, 1).Value = ChrW(&H2713) Then
Cells(a + 1, 1).Select
Range(ActiveCell.Offset(0, 0), ActiveCell.Offset(4, 0)).EntireRow.Hidden = True
End If
Next
Sheets("Sheet1").Range("A4:A500").Value = ""
Range("F1").Select
Application.ScreenUpdating = True
End Sub
Sub copyrange()
Dim LastRow As Long
Dim C As Range
Dim destRow As Long
Dim shtDest As Worksheet
Sheet2.Visible = xlSheetVisible
Set shtDest = Sheets("Sheet2") 'destination sheet
destRow = 2 'start copying to this row
Application.ScreenUpdating = False
With Worksheets("Sheet1")
LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
End With
For Each C In Worksheets("Sheet1").Range("A4:A500") ' & LastRow)
If C.Value = ChrW(&H2713) Then
C.Select
Range(ActiveCell.Offset(0, 1), ActiveCell.Offset(6, 3)).Select
Selection.Copy shtDest.Cells(destRow, 1)
End If
destRow = destRow + 1
Next
Sheet1.Visible = xlSheetVeryHidden
Application.ScreenUpdating = True
DeleteBlankRows
End Sub
Sub DeleteBlankRows()
Dim i As Integer
Dim Rng As Range
Dim WorkRng As Range
Dim xRows As Long
On Error Resume Next
Set WorkRng = Sheets("Sheet2").Range("B1:B500")
xRows = WorkRng.Rows.Count
Application.ScreenUpdating = False
Sheets("Sheet2").Columns("A:A").EntireColumn.Hidden = True
For i = xRows To 1 Step -1
If Application.WorksheetFunction.CountA(WorkRng.Rows(i)) = 0 Then
WorkRng.Rows(i).EntireRow.Delete XlDeleteShiftDirection.xlShiftUp
End If
Next
Application.ScreenUpdating = True
InsertBlankRow
End Sub
Sub InsertBlankRow()
Dim Rng As Range
Application.ScreenUpdating = False
Set Rng = Sheets("Sheet2").Range("A2") '<-- what row do we start with ?
While Rng.Value <> ""
Rng.Offset(6).Resize(1).EntireRow.Insert '<-- Offset = Every X Rows // Resize = How many blank rows to insert
Set Rng = Rng.Offset(7) '<-- Offset # = 6 & 3 above or 9
Wend
Application.ScreenUpdating = True
End Sub
Sub delEmpty()
Dim sht As Worksheet
Dim LastRow As Long
Dim i As Integer
Application.ScreenUpdating = False
Set sht = Sheet2
LastRow = sht.UsedRange.Rows(sht.UsedRange.Rows.Count).Row
For i = LastRow To 2 Step -1
If IsEmpty(Cells(i, 1)) And IsEmpty(Cells(i, 3)) Then
Cells(i, 1).EntireRow.Delete
End If
Next i
Application.ScreenUpdating = True
ProtectAllShts
End Sub
Sub PWenter()
Dim answer As String
answer = InputBox("Enter password.", "Password Request")
If answer = "pw" Then
UnprotectAllShts
Sheet1.Visible = xlSheetVisible
Else
MsgBox "Password Incorrect.", vbCritical & vbOKOnly, "Password Error"
Exit Sub
End If
End Sub
Sub ProtectAllShts()
Dim ws As Worksheet
Dim pwd As String
pwd = "pw" ' Put your password here
For Each ws In Worksheets
ws.Protect Password:=pwd
Next ws
MsgBox "Please email this workbook to sender. Thank you !" & vbNewLine & "The workbook will now close.", vbInformation, "Return Workbook"
Workbooks("Survey Store Visits.xlsm").Close SaveChanges:=True
End Sub
Sub UnprotectAllShts()
Dim ws As Worksheet
Dim pwd As String
pwd = "pw" ' Put your password here
For Each ws In Worksheets
ws.Unprotect Password:=pwd
Next ws
End Sub
Sub WBOpenUnprotectAllShts()
Dim ws As Worksheet
Dim pwd As String
pwd = "pw" ' Put your password here
For Each ws In Worksheets
ws.Unprotect Password:=pwd
Next ws
End Sub
Also ... there is at least one occurrence of the present workbook name in the macro coding. If you change the name of the workbook, you will need to edit the name in the macro/s as well.
Download workbook :
https://www.amazon.com/clouddrive/share/q74IAXJsv9fM5QjmkAV5R4k4okvtXWJFJPvRU5rzVDi
