Copying, Renaming, and Incrementing Duplicate Alphanumeric Cells

[USFengBULLS]

Hello all,
I have a code below that copies the contents in columns A, B and C to the next blank row. I also need this code to Duplicate/Rename the contents in Cell C with, preferably REV 1 after it. Basically here is the format the users will be putting in Column C: LEVEL 1/ AREA A/ RM 125
I would like this code to duplicate that but just put a REV 1 on the end and if there is already a REV 1 then Increment to REV 2 and so on. Something like this:
LEVEL 1/ AREA A/ RM 125
LEVEL 1/ AREA A/ RM 125/ REV 1
LEVEL 1/ AREA A/ RM 125/ REV 2
LEVEL 1/ AREA A/ RM 125/ REV 3
This code below id very close, when it copies down it does rename it with the "/ REV 1" at the end, but when I run it again on that same line it puts another / REV 1. its doing something like this:
LEVEL 1/ AREA A/ RM 125
LEVEL 1/ AREA A/ RM 125/ REV 1
LEVEL 1/ AREA A/ RM 125/ REV 1/ REV 1
LEVEL 1/ AREA A/ RM 125/ REV 1/ REV 1/ REV 1
Does anyone know how I can tweak this code to Increment the number instead of this +1 of each text string?

Public Sub REVISED(tRow As Double)

Dim erow As Double
Dim Dn As Range
Dim Rng As Range

'Copy Cells down to next Blank Row
erow = Sheets("DRAWING SCHEDULE").Cells(Rows.Count, "A").End(xlUp).Offset(1, 0).Row
Range(Cells(tRow, 1), Cells(tRow, 3)).Copy Sheets("DRAWING SCHEDULE").Cells(erow, 1)


'Renames deplicate to REV #
Set Rng = Range(Range("C11"), Range("c" & Rows.Count).End(xlUp))
With CreateObject("scripting.dictionary")
.CompareMode = vbTextCompare
For Each Dn In Rng
If Not .Exists(Dn.Value) Then
.Add Dn.Value, 0
Else
If .Item(Dn.Value) = 0 Then
.Item(Dn.Value) = .Item(Dn.Value) + 1
Dn.Value = Dn.Value & "/ REV 1"
End If
End If
Next Dn
End With



End Sub

 

[MickG]

Does this work for you ???

[COLOR="Navy"]Sub[/COLOR] MG25Jan17
[COLOR="Navy"]Dim[/COLOR] erow [COLOR="Navy"]As[/COLOR] Double
[COLOR="Navy"]Dim[/COLOR] Dn [COLOR="Navy"]As[/COLOR] Range
[COLOR="Navy"]Dim[/COLOR] Rng [COLOR="Navy"]As[/COLOR] Range, trow
trow = 11
'[COLOR="Green"][B]Copy Cells down to next Blank Row[/B][/COLOR]
erow = Sheets("DRAWING SCHEDULE").Cells(Rows.Count, "A").End(xlUp).Offset(1, 0).Row
Range(Cells(trow, 1), Cells(trow, 3)).Copy Sheets("DRAWING SCHEDULE").Cells(erow, 1)
'[COLOR="Green"][B]Renames deplicate to REV #[/B][/COLOR]
[COLOR="Navy"]Set[/COLOR] Rng = Range(Range("A11"), Range("A" & Rows.Count).End(xlUp))
[COLOR="Navy"]For[/COLOR] [COLOR="Navy"]Each[/COLOR] Dn [COLOR="Navy"]In[/COLOR] Rng
    [COLOR="Navy"]If[/COLOR] Dn.Row = Rng(Rng.Count).Row [COLOR="Navy"]Then[/COLOR]
        Dn.Offset(, 2).Value = Dn.Offset(, 2).Value & "/ REV " & Rng.Count - 1
    [COLOR="Navy"]End[/COLOR] If
[COLOR="Navy"]Next[/COLOR] Dn
[COLOR="Navy"]End[/COLOR] [COLOR="Navy"]Sub[/COLOR]

Regards Mick

 

[USFengBULLS]

Thanks Mick, It is stopping due to Duplicate Declarations. I think because I have trow As Double in the Public Sub (). So I then took out the trow after the Dim Rng As Range, trow and now it renamed the Cell with REV 2 at the end instead of REV 1 first. Also, I should mention this code is getting called by a change in Column K at the worksheet level. Here are both codes:

Private Sub Worksheet_Change(ByVal Target As Range)
If Not Intersect(Target, Range("K:K")) Is Nothing Then
If Target.Count > 1 Then Exit Sub
Select Case Target.Value
Case "APPROVED - FV Req.": Call APPROVED(Target.Row)
Case "APPROVED - NO FV Req.": Call APPROVED(Target.Row)
Case "REVISE/AND RESUBMIT": Call REVISED(Target.Row)
End Select
End If
End Sub



Public Sub REVISED(trow As Double)

Dim erow As Double
Dim Dn As Range
Dim Rng As Range
trow = 11
'Copy Cells down to next Blank Row
erow = Sheets("DRAWING SCHEDULE").Cells(Rows.Count, "A").End(xlUp).Offset(1, 0).Row
Range(Cells(trow, 1), Cells(trow, 3)).Copy Sheets("DRAWING SCHEDULE").Cells(erow, 1)
'Renames deplicate to REV #
Set Rng = Range(Range("A11"), Range("A" & Rows.Count).End(xlUp))
For Each Dn In Rng
If Dn.Row = Rng(Rng.Count).Row Then
Dn.Offset(, 2).Value = Dn.Offset(, 2).Value & "/ REV " & Rng.Count - 1
End If
Next Dn



End Sub

 

[MickG]

What happens when you remove duplicates in red:-
NB:- There appears to be more to your data than initially appears !!!
Perhaps an more detailed example would help !!!

Dim Rng As Range[COLOR="#FF0000"], trow
[/COLOR][COLOR="#FF0000"]trow = 11[/COLOR]

 

[USFengBULLS]

Actually I got it working now. Your code was perfect, I just needed to change this line:
Dn.Offset(, 2).Value = Dn.Offset(, 2).Value & "/ REV " & Rng.Count - 1 to
Dn.Offset(, 2).Value = Dn.Offset(, 2).Value & "/ REV " & Rng.Count - 2
and I did take trow out for the Dim statement and it didn't give me anymore fuss about duplicate declarations.
Thanks so much MickG. Super helpful!


If you don't mind, could you help me understand these lines in your code so I may better understand for future?
Set Rng = Range(Range("A11"), Range("A" & Rows.Count).End(xlUp))
For Each Dn In Rng
If Dn.Row = Rng(Rng.Count).Row Then
Dn.Offset(, 2).Value = Dn.Offset(, 2).Value & "/ REV " & Rng.Count - 2

 

[MickG]

Yu're welcome
Glad its working!!!

The code Details:-

'[COLOR="Green"][B]The "Rng" is obviously the range of data from A11" down[/B][/COLOR]
[COLOR="Navy"]Set[/COLOR] Rng = Range(Range("A11"), Range("A" & Rows.Count).End(xlUp))

'[COLOR="Green"][B]loop through Range, "Rng"[/B][/COLOR]
[COLOR="Navy"]For[/COLOR] [COLOR="Navy"]Each[/COLOR] Dn [COLOR="Navy"]In[/COLOR] Rng

'[COLOR="Green"][B]The next line ensures the dn.row is the last row of data, so nothing happens until the last row is found[/B][/COLOR]
'[COLOR="Green"][B]i.e When the Dn.row = The last row in range ("Rng" ) = "Rng(Rng.count).row"[/B][/COLOR]

'[COLOR="Green"][B]So nothing is added until the last row us found[/B][/COLOR]
[COLOR="Navy"]If[/COLOR] Dn.Row = Rng(Rng.Count).Row [COLOR="Navy"]Then[/COLOR]

'[COLOR="Green"][B]This equals the data in last row column "C" plus "/ Rev "  and  Rng(.count) -2, which equal the number of rows in "Rng" -2[/B][/COLOR]
Dn.Offset(, 2).Value = Dn.Offset(, 2).Value & "/ REV "

Regards Mick

 

[USFengBULLS]

Okay, NVM I spoke to soon. I put a bunch more data in to test it and it is now number it wrong because there are more rows. Can I upload this to a dropbox link and you take a look a test it yourself, Obviously I am not good at explaining it on here.
https://www.dropbox.com/s/ir0ha18m2oslxqn/MR Drawing Transmittals Master Form 2019 v1.0.xlsm?dl=0
If you go to DRAWING SCHEDULE Sheet there is some data in there already. In column K there is in cell drop downs and when you select REVISE/AND RESUBMIT it will run/ test this code. Notice the number is off and the I think the copy.