MAcro Problem. How to convert all intergers to 7 characters?

[jscranton]

I have this Macro which works great with one major hitch. The idea here is that when a user inserts a row, it adds .01 to the end of the row. If they insert another row, it becomes .02.

The problem is that I was told everything in Column A would be seven digits. Well, that turned out to be wrong. So I converted all of Column A to seven "digits" with =TEXT((A1)+ "0000000").

However, when my Macro inserts a row, I lose the leading zeroes. This throws off susbsequent row insertions. Any ideas?

Sub InsertRow()
Dim a As Integer
Dim x As String

x = ActiveCell.Value
If Len(x) = 7 Then GoTo NoCountNumber:
On Error GoTo NoCountNumber:
a = CInt(Right(x, 2))
If a > 0 And a < 9 Then
a = a + 1
With ActiveCell
.EntireRow.Copy
.Offset(1, 0).EntireRow.Insert Shift:=xlDown
.Offset(1, 0).Value = Left(x, Len(x) - 2) & CStr("0" & a)

End With
Application.CutCopyMode = False

Else
a = a + 1
With ActiveCell
.EntireRow.Copy
.Offset(1, 0).EntireRow.Insert Shift:=xlDown
.Offset(1, 0).Value = Left(x, Len(x) - 2) & CStr(a)
End With


End If
GoTo Finish:
NoCountNumber:
With ActiveCell
.EntireRow.Copy
.Offset(1, 0).EntireRow.Insert Shift:=xlDown
.Offset(1, 0).Value = x & ".01"
End With
Application.CutCopyMode = False
Finish:
End Sub

 

[VoG]

Maybe like this

.Offset(1, 0).Value = Format(Left(x, Len(x) - 2), "00000000") & CStr("0" & a)

 

[jscranton]

Tried that:

Sub InsertRow()
Dim a As Integer
Dim x As String

x = ActiveCell.Value
If Len(x) = 7 Then GoTo NoCountNumber:
On Error GoTo NoCountNumber:
a = CInt(Right(x, 2))
If a > 0 And a < 9 Then
a = a + 1
With ActiveCell
.EntireRow.Copy
.Offset(1, 0).EntireRow.Insert Shift:=xlDown
.Offset(1, 0).Value = Format(Left(x, Len(x) - 2), "0000000") & CStr("0" & a)

End With
Application.CutCopyMode = False

Else
a = a + 1
With ActiveCell
.EntireRow.Copy
.Offset(1, 0).EntireRow.Insert Shift:=xlDown
.Offset(1, 0).Value = Format(Left(x, Len(x) - 2), "0000000") & CStr(a)
End With


End If
GoTo Finish:
NoCountNumber:
With ActiveCell
.EntireRow.Copy
.Offset(1, 0).EntireRow.Insert Shift:=xlDown
.Offset(1, 0).Value = Format(x, "0000000") & ".01"
End With
Application.CutCopyMode = False
Finish:
End Sub


Same result. The Macro always converts it to a number.

 

[VoG]

Try

With .Offset(1, 0)
    .NumberFormat = "@"
    .Value = Format(Left(x, Len(x) - 2), "00000000") & CStr("0" & a)
End With

 

[jscranton]

Almost. THis works for inserting Row #1 but not for the next row. Can't for the life of me figure out why.

So, NoCountNumber is working. But Not the Other formulas. Do I need to converst a to a string?

Sub InsertRow()
Dim a As Integer
Dim x As String

x = ActiveCell.Value
If Len(x) = 7 Then GoTo NoCountNumber:
On Error GoTo NoCountNumber:
a = CInt(Right(x, 2))
If a > 0 And a < 9 Then
a = a + 1
With ActiveCell
With .Offset(1, 0)
.EntireRow.Copy
.Offset(1, 0).EntireRow.Insert Shift:=xlDown
.NumberFormat = "@"
.Offset(1, 0).Value = Format(Left(x, Len(x) - 2), "0000000") & CStr("0" & a)
End With

End With
Application.CutCopyMode = False

Else
a = a + 1
With ActiveCell
.EntireRow.Copy
.Offset(1, 0).EntireRow.Insert Shift:=xlDown
With .Offset(1, 0)
.NumberFormat = "@"
.Value = Format(Left(x, Len(x) - 2), "0000000") & CStr(a)
End With

End With


End If
GoTo Finish:
NoCountNumber:
With ActiveCell
.EntireRow.Copy
.Offset(1, 0).EntireRow.Insert Shift:=xlDown
With .Offset(1, 0)
.NumberFormat = "@"
.Value = Format(x, "0000000") & ".01"
End With

End With
Application.CutCopyMode = False
Finish:
End Sub

 

[jscranton]

THis almost works. The only issue is that it is double inserting a row. One with the correct value and one without:

Sub InsertRow()
Dim a As Integer
Dim x As String

x = ActiveCell.Value
If Len(x) = 7 Then GoTo NoCountNumber:
On Error GoTo NoCountNumber:
a = CInt(Right(x, 2))
If a > 0 And a < 9 Then
a = CStr(a + 1)

With ActiveCell

.EntireRow.Copy
.Offset(1, 0).EntireRow.Insert Shift:=xlDown
With .Offset(1, 0)
.NumberFormat = "@"
.Offset(1, 0).Value = Format(Left(x, Len(x) - 2), "0000000") & CStr(".0" & a)

End With

End With

Application.CutCopyMode = False

Else
a = CStr(a + 1)

With ActiveCell

.EntireRow.Copy
.Offset(1, 0).EntireRow.Insert Shift:=xlDown
With .Offset(1, 0)
.NumberFormat = "@"
.Value = Format(Left(x, Len(x) - 2), "0000000") & CStr("." & a)
End With

End With

Application.CutCopyMode = False


End If
GoTo Finish:
NoCountNumber:
With ActiveCell
.EntireRow.Copy
.Offset(1, 0).EntireRow.Insert Shift:=xlDown
With .Offset(1, 0)
.NumberFormat = "@"
.Value = Format(x, "0000000") & ".01"
End With

End With
Application.CutCopyMode = False
Finish:
End Sub

 

[jscranton]

Here is my code. When the Value in Row is Len = 7, it works fine. However, inserting the subsequent rows (len<> 7) seems to just copy the previous rows.

x = ActiveCell.Value

If Len(x) = 7 Then GoTo NoCountNumber:
On Error GoTo NoCountNumber:
a = CInt(Right(x, 2))

If a > 0 And a< 9 Then

y = Left(x, Len(x) - 2)


With ActiveCell
.EntireRow.Copy
.Offset(1, 0).EntireRow.Insert Shift:=xlDown

With .Offset(1, 0)
.NumberFormat = "@"
Value = Format(y, "0000000") & (".0" + a)


End With
End With


Application.CutCopyMode = False

Else
a = CStr(a + 1)

With ActiveCell

.EntireRow.Copy
.Offset(1, 0).EntireRow.Insert Shift:=xlDown
With .Offset(1, 0)

.NumberFormat = "@"
.Value = Format(Left(x, Len(x) - 2), "0000000") & CStr("." & a)

End With

End With

Application.CutCopyMode = False


End If
GoTo Finish:
NoCountNumber:
With ActiveCell
.EntireRow.Copy
.Offset(1, 0).EntireRow.Insert Shift:=xlDown
With .Offset(1, 0)
.NumberFormat = "@"
.Value = Format(x, "0000000") & ".01"
End With

End With
Application.CutCopyMode = False
Finish:
End Sub


So, the Macro correctly identified A3 as Len = 7, added .01 to the end and inserted it in the next row.

But, when I try to insert a row on A4, it merely copies it down to the next row.

Excel Workbook
	A	B	C
2	Doc ID	Message Unit ID	Single Email
3	0004028	2338
4	0004028.01	2338
5	0004028.01	2338
OMM Logging Set 1

Excel 2007

 

[jscranton]

Bump?