I have this undermention code that i am using is work ok but i will
like to add a next code to it. i will like to have a code that will
promp the user to click send data to sheet before closing the form


Option Explicit

Private Sub cmdAdd_Click()
Dim iRow As Long
Dim ws As Worksheet
Set ws = Worksheets("main")

'find first empty row in database
iRow = ws.Cells(Rows.Count, 1) _
.End(xlUp).Offset(1, 0).Row

'check for a part number
If Trim(Me.TxtDate.Value) = "" Then
Me.TxtDate.SetFocus
MsgBox "Please enter a part number"
Exit Sub
End If

'copy the data to the database

ws.Cells(iRow, 4).Value = Me.TxtDate.Value
ws.Cells(iRow, 5).Value = Me.TxtPro.Value
ws.Cells(iRow, 6).Value = Me.TxtProtro.Value
ws.Cells(iRow, 7).Value = Me.Txtcov.Value
ws.Cells(iRow, 8).Value = Me.Txtbus.Value
ws.Cells(iRow, 9).Value = Me.Txtwhi.Value
ws.Cells(iRow, 10).Value = Me.Txtgrey.Value
ws.Cells(iRow, 11).Value = Me.Txtser.Value
ws.Cells(iRow, 12).Value = Me.Txtdfo.Value
ws.Cells(iRow, 13).Value = Me.Txtadfo.Value
ws.Cells(iRow, 14).Value = Me.Txtfso.Value
ws.Cells(iRow, 15).Value = Me.Txtcap.Value
ws.Cells(iRow, 16).Value = Me.Txtfsoo.Value
ws.Cells(iRow, 17).Value = Me.Txtff.Value
ws.Cells(iRow, 18).Value = Me.Txtmalebla.Value
ws.Cells(iRow, 19).Value = Me.Txtmalebro.Value
ws.Cells(iRow, 20).Value = Me.Txtfem.Value
ws.Cells(iRow, 21).Value = Me.Txtfireboo.Value
ws.Cells(iRow, 22).Value = Me.Txthelmet.Value
ws.Cells(iRow, 23).Value = Me.Txtden.Value
ws.Cells(iRow, 24).Value = Me.Txtcer.Value
ws.Cells(iRow, 25).Value = Me.Txtund.Value
ws.Cells(iRow, 26).Value = Me.Txttee.Value
ws.Cells(iRow, 27).Value = Me.Txtlar.Value
ws.Cells(iRow, 28).Value = Me.Txtsam.Value
ws.Cells(iRow, 29).Value = Me.Txtsto.Value
ws.Cells(iRow, 30).Value = Me.Txtsock.Value
ws.Cells(iRow, 31).Value = Me.Txtbere.Value
ws.Cells(iRow, 32).Value = Me.Txtcres.Value



'clear the data

Me.TxtDate.Value = ""
Me.TxtPro.Value = ""
Me.TxtProtro.Value = ""
Me.Txtcov.Value = ""
Me.Txtbus.Value = ""
Me.Txtwhi.Value = ""
Me.Txtgrey.Value = ""
Me.Txtser.Value = ""
Me.Txtdfo.Value = ""
Me.Txtadfo.Value = ""
Me.Txtfso.Value = ""
Me.Txtcap.Value = ""
Me.Txtfsoo.Value = ""
Me.Txtff.Value = ""
Me.Txtmalebla.Value = ""
Me.Txtmalebro.Value = ""
Me.Txtfem.Value = ""
Me.Txtfireboo.Value = ""
Me.Txthelmet.Value = ""
Me.Txtden.Value = ""
Me.Txtcer.Value = ""
Me.Txtund.Value = ""
Me.Txttee.Value = ""
Me.Txtlar.Value = ""
Me.Txtsam.Value = ""
Me.Txtsto.Value = ""
Me.Txtsock.Value = ""
Me.Txtbere.Value = ""
Me.Txtcres.Value = ""



Me.TxtDate.SetFocus

End Sub


Private Sub cmdClose_Click()
Unload Me
End Sub




Private Sub UserForm_QueryClose(Cancel As Integer, _
CloseMode As Integer)
If CloseMode = vbFormControlMenu Then
Cancel = True
MsgBox "Please use the button!"
End If
End Sub





Option Explicit

Sub FilterCities()

Dim myCell As Range
Dim wks As Worksheet
Dim DataBaseWks As Worksheet
Dim ListRange As Range
Dim dummyRng As Range
Dim myDatabase As Range
Dim TempWks As Worksheet
Dim rsp As Integer
Dim i As Long

'include bottom most header row
Const TopLeftCellOfDataBase As String = "A4"

'what column has your key values
Const KeyColumn As String = "A"

'where's your data
Set DataBaseWks = Worksheets("Main")
i = DataBaseWks.Range(TopLeftCellOfDataBase).Row - 1

rsp = MsgBox("Include headings?", vbYesNo, "Headings")

Set TempWks = Worksheets.Add

With DataBaseWks
Set dummyRng = .UsedRange
Set myDatabase = .Range(TopLeftCellOfDataBase, _
.Cells.SpecialCells(xlCellTypeLastCell))
End With

'rebuild the List
With DataBaseWks
Intersect(myDatabase, .Columns(KeyColumn)).AdvancedFilter _
Action:=xlFilterCopy, _
CopyToRange:=TempWks.Range("A1"), _
Unique:=True

'Add the heading to the criteria area
TempWks.Range("D1").Value = _
.Cells(.Range(TopLeftCellOfDataBase).Row, KeyColumn).Value
End With

With TempWks
Set ListRange = .Range("a2", .Cells(.Rows.Count,
"A").End(xlUp))
End With

With ListRange
.Sort Key1:=.Cells(1), Order1:=xlAscending, _
Header:=xlNo, OrderCustom:=1, _
MatchCase:=False, Orientation:=xlTopToBottom
End With

'check for individual City worksheets
For Each myCell In ListRange.Cells
If WksExists(myCell.Value) = False Then
Set wks = Sheets.Add
On Error Resume Next
wks.Name = myCell.Value
If Err.Number < 0 Then
MsgBox "Please rename: " & wks.Name
Err.Clear
End If
On Error GoTo 0
wks.Move After:=Sheets(Sheets.Count)
Else
Set wks = Worksheets(myCell.Value)
wks.Cells.Clear
End If

If rsp = 6 Then
DataBaseWks.Rows("1:" & i).Copy Destination:=wks.Range("A1")
End If

'change the criteria in the Criteria range
TempWks.Range("D2").Value = "=" & Chr(34) & "=" & myCell.Value
& Chr(34)

'transfer data to individual City worksheets
If rsp = 6 Then
myDatabase.AdvancedFilter _
Action:=xlFilterCopy, _
CriteriaRange:=TempWks.Range("D1:D2"), _
CopyToRange:=wks.Range("A1").Offset(i, 0), _
Unique:=False
Else
myDatabase.AdvancedFilter _
Action:=xlFilterCopy, _
CriteriaRange:=TempWks.Range("D1:D2"), _
CopyToRange:=wks.Range("A1"), _
Unique:=False
End If
Next myCell

Application.DisplayAlerts = False
TempWks.Delete
Application.DisplayAlerts = True

MsgBox "Data has been sent"

End Sub
Function WksExists(wksName As String) As Boolean
On Error Resume Next
WksExists = CBool(Len(Worksheets(wksName).Name) 0)
End Function