Looping Help Please

[Chris]

Hello, could someone please have a look at the VBA code below and help
me so that it loops three-times. All the code needs to do is locate the
last cell in the worksheet and format three rows (no data in them).
There is a simple formula copied down in column AT.

It works well for one new row but it cannot find the next "LastCell" in
column A as it is empty.

Any help would be very much appreciated.

Kind regards,

Chris.


Sub Add_New_Record()

' Add New Record
'
'

Dim i As Integer
Dim myR As Long

On Error Resume Next

myR = Worksheets("Position and Incumbent Data").Cells(Rows.Count,
1).End(xlUp).Row

For i = 1 To 3


Application.ScreenUpdating = False

Application.EnableEvents = False

With Sheets("Position and Incumbent Data")

.Cells(.Rows.Count, "A").End(xlUp).Name = "LastCell"

.Cells(.Rows.Count, "AT").End(xlUp).Copy _
Destination:=.Cells(.Rows.Count, "AT") _
.End(xlUp).Offset(1, 0)

End With

Application.EnableEvents = True

Range("LastCell").Select

ActiveCell.Offset(1, 0).Range("A1").Select

ActiveCell.Rows("1:1").EntireRow.Select

Selection.RowHeight = 102

ActiveCell.Range("A1:AT1").Select

Selection.Borders(xlDiagonalDown).LineStyle = xlNone
Selection.Borders(xlDiagonalUp).LineStyle = xlNone

With Selection.Font
.Name = "Arial"
.FontStyle = "Regular"
.Size = 8
End With

With Selection
.VerticalAlignment = xlBottom
.WrapText = True
.Orientation = 0
.ShrinkToFit = False
.MergeCells = False
End With

With Selection.Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.Weight = xlHairline
.ColorIndex = xlAutomatic
End With

With Selection.Borders(xlEdgeTop)
.LineStyle = xlContinuous
.Weight = xlHairline
.ColorIndex = xlAutomatic
End With

With Selection.Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.Weight = xlHairline
.ColorIndex = xlAutomatic
End With

With Selection.Borders(xlEdgeRight)
.LineStyle = xlContinuous
.Weight = xlHairline
.ColorIndex = xlAutomatic
End With

With Selection.Borders(xlInsideVertical)
.LineStyle = xlContinuous
.Weight = xlHairline
.ColorIndex = xlAutomatic
End With

With Selection
.VerticalAlignment = xlBottom
.WrapText = True
.Orientation = 0
.ShrinkToFit = False
.MergeCells = False
End With

Sheets("Position and Incumbent Data").Select

Range("LastCell").Offset(2, 0).Select

Next i

Worksheets("Position and Incumbent Data").Cells(myR + 1, 1).Select

End Sub

 

[Joel]

You don't need to loop,just specify more than one row like below. Not sure
which 3 rows you need to format. Once you find the Last Row in the code
below you can make adjusrtments.



Sub Add_New_Record()

' Add New Record
'
'

Dim i As Integer
Dim myR As Long

On Error Resume Next

myR = Worksheets("Position and Incumbent Data") _
.Cells(Rows.Count, 1).End(xlUp).Row


Application.ScreenUpdating = False

Application.EnableEvents = False

With Sheets("Position and Incumbent Data")
LastRow = .Cells(.Rows.Count, "A").End(xlUp)

.Cells(LastRow, "AT").End(xlUp).Copy _
Destination:=.Range(.Cells(LastRow + 1, "AT"), .Cells(LastRow +
3, "AT"))

LastRow = LastRow + 3
.Cells(LastRow, "A").Name = "LastCell"

Application.EnableEvents = True



With .Rows((LastRow + 1) & ":" & (LastRow + 3))

.EntireRow.RowHeight = 102
End With

With .Range("A" & (LastRow + 1) & ":AT" & (LastRow + 3))

.Borders(xlDiagonalDown).LineStyle = xlNone
.Borders(xlDiagonalUp).LineStyle = xlNone

With .Font
.Name = "Arial"
.FontStyle = "Regular"
.Size = 8
End With

.VerticalAlignment = xlBottom
.WrapText = True
.Orientation = 0
.ShrinkToFit = False
.MergeCells = False

With .Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.Weight = xlHairline
.ColorIndex = xlAutomatic
End With

With .Borders(xlEdgeTop)
.LineStyle = xlContinuous
.Weight = xlHairline
.ColorIndex = xlAutomatic
End With

With .Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.Weight = xlHairline
.ColorIndex = xlAutomatic
End With

With .Borders(xlEdgeRight)
.LineStyle = xlContinuous
.Weight = xlHairline
.ColorIndex = xlAutomatic
End With

With .Borders(xlInsideVertical)
.LineStyle = xlContinuous
.Weight = xlHairline
.ColorIndex = xlAutomatic
End With

End With
End With

Sheets("Position and Incumbent Data").Select

Range("LastCell").Offset(2, 0).Select



Worksheets("Position and Incumbent Data").Cells(myR + 1, 1).Select

End Sub

 

[Don Guillett]

Your code can be GREATLY simplified. If desired, send your file to my
address below along with this msg and before/after examples of your desires.

 

[Chris]

Thanks Joel for your help - greatly appreciated.

 

[Chris]

Hi Don, thanks for you help - very much appreciated. I have sent you an
e-mail as requested.

Many thanks,

Chris.

 

[Don Guillett]

Sub AddNewRecord() 'SalesAidSoftware
Application.ScreenUpdating = False
Sheets("Position and Incumbent Data").Select
Dim lr As Long
lr = Cells(Rows.Count, "a").End(xlUp).Row
Range(Cells(lr, "ar"), Cells(lr, "av")). _
AutoFill Range(Cells(lr, "ar"), Cells(lr + 2, "av"))
Range(Cells(lr, "ay"), Cells(lr, "ay")). _
AutoFill Range(Cells(lr, "ay"), Cells(lr + 2, "ay"))
Cells(lr + 1, "w") = "CURRENT"
Cells(lr + 2, "w") = "SECOND"
Cells(lr + 1, "X").Resize(2) = "VACANT"
'format copy
Rows(lr).Copy
Rows(lr + 1).Resize(2).PasteSpecial Paste:=xlPasteFormats
Application.CutCopyMode = False
Cells(lr + 1, 1).Select
Application.ScreenUpdating = True
End Sub