Dat is dus de code met een "loop". Persoonlijk hou ik meer van
For ... Next Step -1
Maar dit type code can zeeeer lang duren...
De volgende code heb ik even getest met 20000 rijen: minder dan 1 seconde.
Option Explicit
Sub insert_rows_on_each_change()
'Erik Van Geit
'080628
'EXAMPLE
'CC = 3, FR = 2, NR = 2
'START WITH
'a1 b1 header d1
'a2 b2 A d2
'a3 b3 A d3
'a4 b4 B d4
'a5 b5 C d5
'a6 b6 C d6
'RESULT
'a1 b1 header d1
'a2 b2 A d2
'a3 b3 A d3
'
'
'a4 b4 B d4
'
'
'a5 b5 C d5
'a6 b6 C d6
Dim rng As Range
Dim LR As Long 'Last Row
Dim CC As Long
Dim FR As Long
Dim NR As Long
Dim NC As Long
'***** EDIT the following lines ****
CC = 1 'Check this Column
FR = 2 'First Row with data: MINIMUM = 2
NR = 1 'Number of Rows to insert
NC = 3 'Number of Columns to color
'***** END EDIT ****
Application.ScreenUpdating = False
LR = Cells(Rows.Count, CC).End(xlUp).Row
Columns(CC).EntireColumn.Insert
Set rng = Range(Cells(FR + 1, CC), Cells(LR, CC))
Cells(FR, CC) = 1
With rng
.FormulaR1C1 = "=IF(RC[1]=R[-1]C[1],R[-1]C,R[-1]C+1)"
.Value = .Value
With .Offset(.Rows.Count, 0)
.Cells(1, 1).Value = 1
With .Resize(.Cells(1, 1).Offset(-1, 0) - 1, 1)
.DataSeries Rowcol:=xlColumns, Type:=xlLinear, step:=1
With .Resize(, NC + 1)
.Interior.ColorIndex = 15
.Copy .Resize(NR * .Rows.Count, 1)
.RowHeight = 5
End With
End With
End With
LR = Cells(Rows.Count, CC).End(xlUp).Row
Range(Cells(FR, CC), Cells(LR, CC)).EntireRow.Sort Key1:=.Cells(1, 1)
End With
Columns(CC).EntireColumn.Delete
Application.ScreenUpdating = True
End Sub
Als je er doorheen loopt met funcietoets F8, dan kan je op je werkblad volgen wat er gebeurt. Dit proces kan je zelfs manueel in korte tijd uitvoeren (als je wat handig bent zeker in 1 minuut)
De code laat toe, dat je instelt:
1. welke kolom er nagekeken wordt
2. welke de eerste rij is
3. hoeveel rijen er tussen komen
4. hoeveel kolommen er gekleurd moeten worden
Om compleet te zijn zou de code ook even moeten checken of er wel voldoende rijen kunnen worden ingevoegd!
goeienavond,
Erik