Quote:
Originally Posted by BjornS
Hi,
try this instead!
Good night (at least in my part of the world :-)
Kind regards
Bjorn
Sub FixRows()
Application.ScreenUpdating = False
Dim rownum As Long
Dim rowhour As Long
Dim CopyOffset As Long
rownum = 4
rowhour = 0
Do Until Cells(rownum, 4).Value = "" And rowhour = 0
If Cells(rownum, 4).Value <> rowhour And Cells(rownum, 4).Value Mod 100 = 0 Then
Cells(rownum, 1).EntireRow.Insert
If rownum = 4 Then CopyOffset = 1 Else CopyOffset = -1
Cells(rownum + CopyOffset, 1).Range("A1:L1").Copy _
Destination:=Cells(rownum, 1)
Cells(rownum, 4).Value = rowhour
If rowhour Mod 300 = 0 Then
With Cells(rownum, 5)
.NumberFormat = "0"
.FormulaR1C1 = "9999"
.Interior.ColorIndex = 6
.Interior.Pattern = xlSolid
.Borders.LineStyle = xlcontinous
.Borders.Weight = xlThin
.Borders.ColorIndex = xlAutomatic
End With
Cells(rownum, 5).Copy Destination:=Cells(rownum, 1).Range("E1:L1")
End If
End If
rownum = rownum + 1
rowhour = rowhour + 100
If rowhour = 2400 Then rowhour = 0
Loop
Application.ScreenUpdating = False
End Sub
|
Thank you Bjorn, you fixed my problems COMPLETELY and I am very honored to contact with you, I wish we will still in contact I am very pleased to have a friend like you, I will send you my contact on a private message. It is also bed time in my world
I live in Jordan, and it is now 12.33Am. Again, I highly appreciate your patience with me
Best of luck my friend, and God bless you.
Tareq.