Can you advise a different way of this code to work please

[ipbr21054]

Morning,
Please see working code shown below.

I have a worksheet where i enter data and in column G, the word POSTED is shown & also RED.
Once the parcel has been delivered on my userform i select the customer and press the command button.

Now looking on my worksheet i see what was POSTED "red highlite" is now yellow and 16/02/2020 etc etc

So looking at my code each time i press the command button i see a msgbox "do you want to open the userform"
No closes the msgbox & i work on the worksheet.
Yes then runs the code to see if there are any POSTED in column G
Depending on the outcome the form opens OR i am told all parcels delivered and userfrom doen not open.

WOW.
What can we do so i dont see the question everytime DO YOU WISH TO OPEN THE USERFORM ?

I just seem to be pressing YES all the time

Private Sub Openuserform_Click()
Dim answer As Integer
answer = MsgBox("DO YOU WISH TO OPEN THE USERFORM", vbQuestion + vbYesNo + vbDefaultButton2, "POSTAGE OPEN USERFORM MESSAGE")
If answer = vbNo Then
  Exit Sub
Else
End If

Dim ws As Worksheet
Set ws = Sheets("POSTAGE")
Dim i As Integer
i = 1
Do Until i = 5000 ' <-- change number rows to check here
    If ws.Range("G" & i).Interior.Color = RGB(255, 0, 0) And ws.Range("G" & i).Value = "POSTED" Then
        PostageTransferSheet.Show
        Exit Sub
    End If
i = i + 1
Loop
MsgBox "NO NAMES TO SHOW AS ALL PARCELS HAVE NOW BEEN DELIVERED", vbInformation, "POSTAGE DATE TRANSFER SHEET MESSAGE"

End Sub

 

[ipbr21054]

Do you mean like this ?

Because i still get the same message but the i this time is shown ?

Private Sub Openuserform_Click()
Dim ws As Worksheet
Set ws = Sheets("POSTAGE")
Dim FirstRow As Long, LastRow As Long, fCell As Range
Set fCell = ws.Range("G:G").Find("POSTED", ws.Range("G1"), xlValues, xlWhole)
If Not fCell Is Nothing Then
    FirstRow = fCell.Row
    LastRow = ws.Cells(Rows.Count, 7).End(xlUp).Row
    Do Until FirstRow = LastRow
        If ws.Range("G" & i).Interior.Color = RGB(255, 0, 0) And ws.Range("G" & i).Value = "POSTED" Then
            PostageTransferSheet.Show
            Exit Sub
        End If
    LastRow = LastRow + 1
    Loop
Else
    MsgBox "NO NAMES TO SHOW AS ALL PARCELS HAVE NOW BEEN DELIVERED", vbInformation, "POSTAGE DATE TRANSFER SHEET MESSAGE"
End If
End Sub

 

[jasonb75]

I think I need to start today again, things do not appear to be going according to plan ?
I think that I've corrected all of the mistakes I made this time,

Private Sub Openuserform_Click()
Dim ws As Worksheet
Set ws = Sheets("POSTAGE")
Dim FirstRow As Long, LastRow As Long, fCell As Range
Set fCell = ws.Range("G:G").Find("POSTED", ws.Range("G1"), xlValues, xlWhole)
If Not fCell Is Nothing Then
    FirstRow = fCell.Row
    LastRow = ws.Cells(Rows.Count, 7).End(xlUp).Row
    Do Until FirstRow = LastRow
        If ws.Range("G" & FirstRow).Interior.Color = RGB(255, 0, 0) And ws.Range("G" & FirstRow).Value = "POSTED" Then
            PostageTransferSheet.Show
            Exit Sub
        End If
    FirstRow = FirstRow + 1
    Loop
Else
    MsgBox "NO NAMES TO SHOW AS ALL PARCELS HAVE NOW BEEN DELIVERED", vbInformation, "POSTAGE DATE TRANSFER SHEET MESSAGE"
End If
End Sub

 

[ipbr21054]

Perfect works great many thanks.


I will start another post & maybe you could advise there if you have time.

 

[jasonb75]

Now that we know the code works, here's the revised version to try and make it a bit faster, this could probably still be refined a bit.

Private Sub Openuserform_Click()
Dim ws As Worksheet
Set ws = Sheets("POSTAGE")
Dim FirstRow As Long, LastRow As Long, fCell As Range
Static FirstTime As Boolean
If firtsttime = False Then Set fCell = ws.Range("G:G").Find("POSTED", ws.Range("G1"), xlValues, xlWhole)
If Not fCell Is Nothing Then
    FirstTime = True
    FirstRow = fCell.Row
    LastRow = ws.Cells(Rows.Count, 7).End(xlUp).Row
    Do Until FirstRow > LastRow
        If ws.Range("G" & FirstRow).Interior.Color = RGB(255, 0, 0) And ws.Range("G" & FirstRow).Value = "POSTED" Then
            PostageTransferSheet.Show
            Exit Sub
        End If
    FirstRow = FirstRow + 1
    Loop
End If
    MsgBox "NO NAMES TO SHOW AS ALL PARCELS HAVE NOW BEEN DELIVERED", vbInformation, "POSTAGE DATE TRANSFER SHEET MESSAGE"
    FirstTime = False
End Sub

I'll be offline for the rest of the day, I'll check either late tonight or in the morning to see how well this works (that is if it works given my track record so far today).

 

[ipbr21054]

Ive now changed the code in the vba editor but i cant the page down at all.
Complie error variable not defined.

See where it debugs too.
"firsttime"

Private Sub Openuserform_Click()
Dim ws As Worksheet
Set ws = Sheets("POSTAGE")
Dim FirstRow As Long, LastRow As Long, fCell As Range
Static FirstTime As Boolean
If firtsttime = False Then Set fCell = ws.Range("G:G").Find("POSTED", ws.Range("G1"), xlValues, xlWhole)
If Not fCell Is Nothing Then
    FirstTime = True
    FirstRow = fCell.Row
    LastRow = ws.Cells(Rows.Count, 7).End(xlUp).Row
    Do Until FirstRow > LastRow
        If ws.Range("G" & FirstRow).Interior.Color = RGB(255, 0, 0) And ws.Range("G" & FirstRow).Value = "POSTED" Then
            PostageTransferSheet.Show
            Exit Sub
        End If
    FirstRow = FirstRow + 1
    Loop
End If
    MsgBox "NO NAMES TO SHOW AS ALL PARCELS HAVE NOW BEEN DELIVERED", vbInformation, "POSTAGE DATE TRANSFER SHEET MESSAGE"
    FirstTime = False
End Sub

 

[jasonb75]

That was a typo that I missed, it should be FirstTime

 

[ipbr21054]

Thats seems to have done the trick.

Thanks,
Could you now look at the next one which stil relates to this form please.

Need some advice for code edit please

Hi, Please see the code in use. On my worksheet i select a name from textbox called NameForDateEntryBox I then press the command button called DateTransferButton What this does is put todays date against the customer selected on the worksheet. This all works fine BUT when i first started this...

www.mrexcel.com

 

[ipbr21054]

WAIT

Not sure what you changed BUT now & then when i click the command button to open the userform i see the message NO NAMES TO SHOW AS ALL PARCELS HAVE NOW BEEN DELIVERED
Which is incorrect because i see cells which have POSTED in them.

I should only see this message when there are no cells in column G where its red & the text POSTED is shown

 

[jasonb75]

See if this fixes it, I've been over the code several times and can't see any reason for it to miss the 'Posted' cells.

Private Sub Openuserform_Click()
Dim ws As Worksheet
Set ws = Sheets("POSTAGE")
Dim FirstRow As Long, LastRow As Long, fCell As Range
Static FirstTime As Boolean
If FirstTime = False Then Set fCell = ws.Range("G:G").Find(What:="POSTED", After:=ws.Range("G1"), LookIn:=xlValues, LookAt:=xlWhole, MatchCase:=False, SearchFormat:=False)
If Not fCell Is Nothing Then
    FirstTime = True
    FirstRow = fCell.Row
    LastRow = ws.Cells(Rows.Count, 7).End(xlUp).Row
    Do Until FirstRow > LastRow
        If ws.Range("G" & FirstRow).Interior.Color = RGB(255, 0, 0) And ws.Range("G" & FirstRow).Value = "POSTED" Then
            PostageTransferSheet.Show
            Exit Sub
        End If
    FirstRow = FirstRow + 1
    Loop
End If
    MsgBox "NO NAMES TO SHOW AS ALL PARCELS HAVE NOW BEEN DELIVERED", vbInformation, "POSTAGE DATE TRANSFER SHEET MESSAGE"
    FirstTime = False
End Sub

If that doesn't work, would you be able to upload a copy of the file with some dummy data so that I can run it and see what is being missed?

 

[ipbr21054]

Hi,
Take a look at this.
This is using the code you just advised.

https://www.theremotedoctor.co.uk/forums/EXCELPOSTAGE.mp4