22. juli 2015 - 11:33
Der er
5 kommentarer og
1 løsning
Indsætte tomme linjer ved manglende datoer
I et ark, sætter jeg datoer med noget andet ( i andre kolonner) ind i kolonne A.
Der mangler som regel nogle datorer:
1/6
2/6
5/6
6/6
her er der 3/6 og 4/6, der mangler. Så jeg vil gerne sætte tomme linjer ind mellem 2/6 og 5/6, hvis muligt.
Der skal udfyldes med tomme linjer indtil månedsslut...
Helst ikke i VBA, men gerne makro, det kan jeg som regel overskue :-).
Der er ca 2000 linjer med datoer, som alle er samme måned. Det er ca 100 afsnit med datoer, her juni måned.
Kan I hjælpe mig med dette?
mvh Johnny
Måske er jeg ikke så kvik. Jeg mener bare, at jeg har indspillet makroer og husker det som nogenlunde overskueligt...
VBA og sætte det ind, plejer at volde mig problemer.
mvh Johnny
Public Sub indsætTommeRækker()
Dim sidsteRække As Long, ræk As Long, antalTomme As Integer, slutFlag As Boolean
Dim ptMåned As Integer, ptÅr As Integer, ptFørste As Date, ptAntalDage As Integer
Dim ptDato As Date, nextDato As Date, startOk As Boolean, slutOk As Boolean
Rem Klargøring
sidsteRække = ActiveCell.SpecialCells(xlLastCell).Row
ptMåned = Month(Range("A1"))
ptÅr = Year(Range("A1"))
ptFørste = "01-" & CStr(ptMåned) & "-" & CStr(ptÅr)
ptAntalDage = hentAntalDage(ptFørste)
startOk = False
slutOk = False
slutFlag = False
Application.ScreenUpdating = False
For ræk = 1 To 9999
antalTomme = 0
ptFørste = "01-" & CStr(ptMåned) & "-" & CStr(ptÅr)
If Range("A" & ræk) <> "" Then
Range("A" & ræk).Select
ptDato = Selection
Rem test månedens start (fra den 1. til ptDato)
While ptDato > ptFørste And startOk = False
Rows(ræk & ":" & ræk).Select
Selection.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
ptFørste = DateAdd("d", 1, ptFørste)
antalTomme = antalTomme + 1
Wend
startOk = True
If antalTomme > 0 Then
Range("A" & ræk + antalTomme).Select
End If
nextDato = Selection.Offset(1, 0)
While DateAdd("d", 1, ptDato) < nextDato
If DateDiff("d", ptDato, nextDato) > 1 Then
antalTomme = antalTomme + 1
Rows(ræk + 1 & ":" & ræk + 1).Insert
ptDato = DateAdd("d", 1, ptDato)
Else
antalTomme = antalTomme - 1
End If
Wend
ræk = ræk + antalTomme
Else
antalTomme = 0
startOk = False
Rem test månedens afslut - fra ptDato til sidste dag i mpneden
While ptDato < CStr(ptAntalDage) & "-" & CStr(ptMåned) & "-" & CStr(ptÅr)
Rows(ræk & ":" & ræk).Select
Selection.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
ptDato = DateAdd("d", 1, ptDato)
antalTomme = antalTomme + 1
Wend
ræk = ræk + antalTomme
End If
Next ræk
End Sub
Function hentAntalDage(dato)
hentAntalDage = Day(DateSerial(Year(dato), Month(dato) + 1, 1) - 1)
End Function
