Insert new row & apply Ucase

I

ipbr21054

Well-known Member
Joined
Nov 16, 2010
Messages
5,832
Office Version
  1. 2007
Platform
  1. Windows
Hi,

Can you advise please the correct way to apply Ucase for when i insert a new row each time at A6:H6

I have this code below but keep getting Run Time Error 13

Code: 
Private Sub InsertNewRow_Click()Rows("6:6").Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
Range("A6").Select
Range("A6:H6").Font.Size = 18
Range("A4:H6").Font.Bold = True
Range("A6:H6").Interior.ColorIndex = 6
Range("A6:H6").Borders.LineStyle = xlContinuous
Range("A6:H6").Borders.Weight = xlThin
Range("A6:H6").HorizontalAlignment = xlCenter
Range("A6:H6").VerticalAlignment = xlCenter
Range("A6:H6").Name = "Calibri"
Range("A6:H6").RowHeight = 30
[COLOR=#ff0000]Range("A6:H6").Value = UCase(Range("A6:H6").Value)[/COLOR]
End Sub

Many Thanks
 

Excel Facts

Format cells as currency
Select range and press Ctrl+Shift+4 to format cells as currency. (Shift 4 is the $ sign).
Sort by date Sort by votes
Not sure what you are trying to achieve here. Because you are inserting a new row then there will be no values to convert to upper case. If you want everything entered at row 6 to be upper case then you will need a worksheet change event to covert any values entered in A6:H6 to upper case. Eg:

Code: 
Private Sub Worksheet_Change(ByVal Target As Range)
    If Not Intersect(Target, Me.Range("A6:H6")) Is Nothing Then
        Dim c As Range
        For Each c In Target
            c.Value = UCase(c.Value)
        Next c
    End If
End Sub
 
Upvote 0
If you leave "Value" off, does that do it?
Code: 
Range("A6:H6") = UCase(Range("A6:H6"))

BTW, I would do it slightly different (Delete the "Select" line)
Code: 
With Range("A6:H6")
    .Font.Size = 18
    .Font.Bold = True
    ' continue with the rest
End With
 
Upvote 0
i'd probably do something like this just to try and keep some sort of undo stack intact.

For your insert rows sub:
Code: 
Private Sub InsertNewRow_Click()
    Application.EnableEvents = False
    Rows("6:6").Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
    With Range("A6:H6")
        .Font.Size = 18
        .Font.Bold = True
        .Interior.ColorIndex = 6
        .Borders.LineStyle = xlContinuous
        .Borders.Weight = xlThin
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlCenter
        .Name = "Calibri"
        .RowHeight = 30
    End With
    Application.EnableEvents = True
End Sub

in a vba module:
Code: 
Private stack As Collection


Public Sub setUndo(Optional ByRef r As Range)
    If stack Is Nothing Then Set stack = New Collection
    If Not r Is Nothing Then
        stack.Add Array(r, r.Formula)
    Else
        If stack.Count > 0 Then Application.onUndo "Undo typing in " & stack(stack.Count)(0).Address, "onUndo"
    End If
End Sub


Public Sub onUndo(Optional ByVal b As Boolean)
    If Not stack Is Nothing Then
        If stack.Count > 0 Then
            Dim rng As Range, r As Range, c As Range
            Dim v As Variant
            Dim i As Long, j As Long
            
            Set rng = stack(stack.Count)(0)
            v = stack(stack.Count)(1)
            i = 0: j = 0
            Application.EnableEvents = False
            For Each r In rng.Rows
                i = i + 1
                For Each c In r
                    j = j + 1
                    If IsArray(v) Then
                        c.Formula = v(i, j)
                    Else
                        c.Formula = v
                    End If
                Next c
            Next r
            Application.EnableEvents = True
            stack.Remove stack.Count
            Application.OnTime Now() + TimeValue("00:00:01"), "setUndo"
        End If
    End If
End Sub

in your worksheet module:
Code: 
Private Sub Worksheet_Change(ByVal Target As Range)
    If Not Intersect(Target, Me.Range("A6:H6")) Is Nothing Then
        Dim c As Range
        Dim v As Variant
        Application.EnableEvents = False
        Application.ScreenUpdating = False
        v = Target.Formula
        Application.Undo
        setUndo Target
        Target.Formula = v
        For Each c In Target
            c.Value = UCase(c.Value)
        Next c
        Application.EnableEvents = True
        Application.ScreenUpdating = True
        Application.onUndo "Undo typing in " & Target.Address, "onUndo"
    End If
End Sub
 
Last edited:
Upvote 0
Afternoon,

I have the select piece so i can start typing straight away otherwise i need to select the cell before i can write.

The code in post #3 did not work for me so looking at the code in post #2 how would i add it to the existing Change event currently in use.

Code: 
Private Sub Worksheet_Change(ByVal Target As Range)
Dim c As Range
  On Error GoTo AllowEvents
  If Target.Count > 1000 Then Exit Sub
  If Not Intersect(Target, Range("B:B")) Is Nothing Then
    For Each c In Target
      If c.Row > 5 And c.Column = 2 Then
          If Len(c.Value) <> 17 And Len(c.Value) > 0 Then
          Application.EnableEvents = False
          MsgBox "VIN MUST BE 17 CHARACTERS", vbCritical, "VIN CHARACTER COUNT MESSAGE"
          c.Value = ""
          c.Select
          Else
              c.Characters(Start:=10, Length:=1).Font.ColorIndex = 3
       
        End If
      End If
    Next
  End If
AllowEvents:
  Application.EnableEvents = True
 
End Sub
 
Upvote 0
just stick it at the end

Code: 
Private Sub Worksheet_Change(ByVal Target As Range)
    Dim c As Range
    On Error GoTo AllowEvents
    If Target.Count > 1000 Then Exit Sub
    Application.EnableEvents = False
    If Not Intersect(Target, Range("B:B")) Is Nothing Then
      For Each c In Target
        If c.Row > 5 And c.Column = 2 Then
            If Len(c.Value) <> 17 And Len(c.Value) > 0 Then
            MsgBox "VIN MUST BE 17 CHARACTERS", vbCritical, "VIN CHARACTER COUNT MESSAGE"
            c.Value = ""
            c.Select
            Else
                c.Characters(Start:=10, Length:=1).Font.ColorIndex = 3
         
          End If
        End If
      Next
    End If
    If Not Intersect(Target, Me.Range("A6:H6")) Is Nothing Then
        Application.ScreenUpdating = False
        For Each c In Target
            c.Value = UCase(c.Value)
        Next c
        Application.ScreenUpdating = True
    End If
    
AllowEvents:
    Application.EnableEvents = True
End Sub

Or if you decide to use the one with undo stack manipulation:
Code: 
Private Sub Worksheet_Change(ByVal Target As Range)
    Dim c As Range
    Dim v As Variant
    On Error GoTo AllowEvents
    If Target.Count > 1000 Then Exit Sub
    Application.EnableEvents = False
    If Not Intersect(Target, Range("B:B")) Is Nothing Then
      For Each c In Target
        If c.Row > 5 And c.Column = 2 Then
            If Len(c.Value) <> 17 And Len(c.Value) > 0 Then
            MsgBox "VIN MUST BE 17 CHARACTERS", vbCritical, "VIN CHARACTER COUNT MESSAGE"
            c.Value = ""
            c.Select
            Else
                c.Characters(Start:=10, Length:=1).Font.ColorIndex = 3
         
          End If
        End If
      Next
    End If
    If Not Intersect(Target, Me.Range("A6:H6")) Is Nothing Then
        Application.ScreenUpdating = False
        v = Target.Formula
        Application.Undo
        setUndo Target
        Target.Formula = v
        For Each c In Target
            c.Value = UCase(c.Value)
        Next c
        Application.ScreenUpdating = True
        Application.onUndo "Undo typing in " & Target.Address, "onUndo"
    End If
    
AllowEvents:
    Application.EnableEvents = True
End Sub
 
Last edited:
Upvote 0
Using your stack manipulation code i get the message,
Compile error, Sub or function not defined.

Code: 
Private Sub Worksheet_Change(ByVal Target As Range)    Dim c As Range
    Dim v As Variant
    On Error GoTo AllowEvents
    If Target.Count > 1000 Then Exit Sub
    Application.EnableEvents = False
    If Not Intersect(Target, Range("B:B")) Is Nothing Then
      For Each c In Target
        If c.Row > 5 And c.Column = 2 Then
            If Len(c.Value) <> 17 And Len(c.Value) > 0 Then
            MsgBox "VIN MUST BE 17 CHARACTERS", vbCritical, "VIN CHARACTER COUNT MESSAGE"
            c.Value = ""
            c.Select
            Else
                c.Characters(Start:=10, Length:=1).Font.ColorIndex = 3
         
          End If
        End If
      Next
    End If
    If Not Intersect(Target, Me.Range("A6:H6")) Is Nothing Then
        Application.ScreenUpdating = False
        v = Target.Formula
        Application.Undo
        [COLOR=#ff0000]setUndo [/COLOR]Target
        Target.Formula = v
        For Each c In Target
            c.Value = UCase(c.Value)
        Next c
        Application.ScreenUpdating = True
        Application.OnUndo "Undo typing in " & Target.Address, "onUndo"
    End If
    
AllowEvents:
    Application.EnableEvents = True
End Sub
 
Upvote 0
you need to have added this code to a regular module first:

Code: 
Private stack As Collection

Public Sub setUndo(Optional ByRef r As Range)
    If stack Is Nothing Then Set stack = New Collection
    If Not r Is Nothing Then
        stack.Add Array(r, r.Formula)
    Else
        On Error Resume Next
        If stack.Count > 0 Then Application.onUndo "Undo typing in " & stack(stack.Count)(0).Address, "onUndo"
        On Error GoTo 0
    End If
End Sub


Public Sub onUndo(Optional ByVal b As Boolean)
    If Not stack Is Nothing Then
        If stack.Count > 0 Then
            Dim rng As Range
            Dim v As Variant
            
            Set rng = stack(stack.Count)(0)
            v = stack(stack.Count)(1)
            Application.EnableEvents = False
            rng.Formula = v
            Application.EnableEvents = True
            stack.Remove stack.Count
            Application.OnTime Now() + TimeValue("00:00:01"), "setUndo"
        End If
    End If
End Sub

also, i have tweaked the change event code slightly to cope with row deletions:
Code: 
Private Sub Worksheet_Change(ByVal Target As Range)
    Dim c As Range
    On Error GoTo AllowEvents
    If Target.Count > 1000 Then Exit Sub
    Application.EnableEvents = False
    If Not Intersect(Target, Range("B:B")) Is Nothing Then
      For Each c In Target
        If c.Row > 5 And c.Column = 2 Then
            If Len(c.Value) <> 17 And Len(c.Value) > 0 Then
            MsgBox "VIN MUST BE 17 CHARACTERS", vbCritical, "VIN CHARACTER COUNT MESSAGE"
            c.Value = ""
            c.Select
            Else
                c.Characters(Start:=10, Length:=1).Font.ColorIndex = 3
         
          End If
        End If
      Next
    End If
    If Not Intersect(Target, Me.Range("A6:H6")) Is Nothing Then
        Application.ScreenUpdating = False
        Application.Undo
        setUndo Target
        Application.Undo
        For Each c In Target
            c.Value = UCase(c.Value)
        Next c
        Application.ScreenUpdating = True
        Application.onUndo "Undo typing in " & Target.Address, "onUndo"
    End If
    
AllowEvents:
    Application.EnableEvents = True
End Sub
 
Last edited:
Upvote 0
ipbr21054 said:
Code: 
[COLOR=#ff0000]Range("A6:H6").Value = UCase(Range("A6:H6").Value)[/COLOR]
Click to expand...
To eliminate the error the above line generates, replace it with this one...
Code: 
Range("A6:H6").Value = Evaluate("IF(A6:H6="""","""",UPPER(A6:H6))")
 
Last edited:
Upvote 0
I did but thats the message i see.

If i add it like this it works but is it correct

Code: 
[COLOR=#333333]setUndo = Target[/COLOR]
 
Upvote 0
You must log in or register to reply here.

Similar threads

I
  • Question Question
Use the majority of an existing working code in new project advice
Replies
1
Views
220
ipbr21054
I
I
  • Solved
Cell above is selected when i duplicate row
Replies
2
Views
369
ipbr21054
I
H
  • Question Question
Save and Close Excel after a 15min inactivity.
Replies
4
Views
784
Hopey87
H
J
  • Question Question
Applying VBA to other cells
Replies
2
Views
474
NoSparks
N
I
  • Question Question
Add ID number next to customer row from userform transfer
Replies
2
Views
324
Joe4
Joe4

Forum statistics

Threads
1,224,823
Messages
6,181,178
Members
453,021
Latest member
Justyna P

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top