Help with VBA to find data delete it change font, add lines then looptill end of file

  • Thread starter Thread starter Ez Duzit
  • Start date Start date
E

Ez Duzit

Hello,

I have what I want in the VBA but it only changes one time and I would like to loop it throughout the one "COLUMN A" till the end to find rows containing a ".1" and moving on to the next one and so on.... Below is my example.

Your help is greatly appreciated.

===================================================
Starting example

COLUMN A COLUMN D
11.1 DETAIL 1
20.1 DETAIL 2
25 Diameter: .865 - .885 in
28.1 DETAIL 3
29 Linear Dimension: .360 - .390 in

=====================================================
End example

COLUMN A COLUMN D
(added line)
DETAIL 1 (font changed)
(added line)
DETAIL 2 (font changed)
(added line)
25 Diameter: .865 - .885 in
(added line)
DETAIL 3 (font changed)
(added line)
29 Linear Dimension: .360 - .390 in

=======================================================

Below is the code that works for the first instance...

Sub DETAILS()

'ADD NOTES COMMENT
'
Range("A:A").Find(What:=".1", After:=ActiveCell, LookIn:=xlFormulas, LookAt _
:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:= _
False, SearchFormat:=False).Activate
Selection.ClearContents
ActiveCell.Offset(0, 3).Select
Selection.Font.Bold = True
With Selection.Font
.Name = "DISCUS GDT"
.Size = 12
.Strikethrough = False
.Superscript = False
.Subscript = False
.OutlineFont = False
.Shadow = False
.Underline = xlUnderlineStyleNone
.ColorIndex = xlAutomatic
.TintAndShade = 0
.ThemeFont = xlThemeFontNone
End With
With Selection
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
.WrapText = True
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
Selection.EntireRow.Insert , CopyOrigin:=xlFormatFromLeftOrAbove
Selection.Merge
ActiveCell.Offset(1, 0).Select
ActiveCell.Offset(1, 0).Select
Selection.EntireRow.Insert , CopyOrigin:=xlFormatFromLeftOrAbove
Selection.Merge

End Sub
 
Hi,

Am Wed, 7 Jan 2015 13:50:06 -0800 (PST) schrieb Ez Duzit:
I have what I want in the VBA but it only changes one time and I would like to loop it throughout the one "COLUMN A" till the end to find rows containing a ".1" and moving on to the next one and so on.... Below is my example.
Click to expand...

try:

Sub Test()
Dim n As Long

n = 1
With ActiveSheet
Do
If Right(.Cells(n, 1) * 10, 1) = 1 Then
.Cells(n, 1).ClearContents
With .Cells(n, 4)
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
With .Font
.Name = "DISCUS GDT"
.Size = 12
End With
End With
.Rows(n).Insert
n = n + 1
End If
n = n + 1
Loop While Len(.Cells(n, 1)) > 0
End With
End Sub


Regards
Claus B.
 
Back
Top