Sub dan_specifikationer()
Dim sFlag As Integer, sumIår As Single, sumSår As Single, sumTekst As String
Dim poster()
Dim I, J, K, Flyt As Boolean
Dim Rng As Range
sFlag = 0
Application.ScreenUpdating = False
Worksheets("spec1").Activate
Cells.Rows.Hidden = False
Cells.PageBreak = xlPageBreakNone
With Worksheets("Konto") 'tilrettes til ark med data
data = .Range("A2:O" & .Range("B7000").End(xlUp).Row + 1)
.Range("C7000").End(xlUp).Value = WorksheetFunction.Sum(.Range("C1:C6223")) * -1
.Range("E7000").End(xlUp).Value = WorksheetFunction.Sum(.Range("E1:E6223")) * -1
End With
With Worksheets("overskrift") 'tilrettes til ark med overskrifter
Overskrifter = .Range("A2:C" & .Range("B200").End(xlUp).Row)
End With
sidstedata = UBound(data)
rækkestart = 1
For I = 1 To UBound(Overskrifter) 'Overskrifter løbes igennem
For J = 1 To sidstedata 'antal poster = kriterier tælles op
If data(J, 7) = Overskrifter(I, 1) Or data(J, 10) = Overskrifter(I, 1) Then
If data(J, 3) <> 0 Or data(J, 5) <> 0 Then
K = K + 1
End If
End If
Next J
If K > 0 Then
ReDim poster(K - 1, 7)
K = 0
For J = 1 To sidstedata 'Kontoplan løbes igennem
If data(J, 7) = Overskrifter(I, 1) Then
Rem Er der værdi <> 0 i kolonne C eller E
If data(J, 3) <> 0 Or data(J, 5) <> 0 Then
Rem Er der Nr i kolonne N / O
EfterBrud:
If data(J, 14) <> "" Then
sFlag = data(J, 14)
sumIår = 0
sumSår = 0
sumTekst = "??"
While sFlag = data(J, 14)
sumIår = sumIår + (data(J, 3) * data(J, 9))
sumSår = sumSår + (data(J, 5) * data(J, 9))
totaliår = totaliår + (data(J, 3) * data(J, 9))
totalsidsteår = totalsidsteår + (data(J, 5) * data(J, 9))
If data(J, 15) <> 0 Then
sumTekst = data(J, 2)
End If
J = J + 1
Wend
Rem brud på "samle-Nr"
poster(K, 1) = sumTekst
poster(K, 3) = sumIår
poster(K, 5) = sumSår
K = K + 1
GoTo EfterBrud
End If
'poster(K, 0) = data(J, 1) 'tom
poster(K, 1) = data(J, 2) 'tekst/kontonavn
poster(K, 3) = data(J, 3) * data(J, 9) 'beløb i år
'poster(K, 4) = data(J, 4) 'tomt
'************************************* KABBAK *************************************************
If data(J, 10) = Empty Or data(J, 7) = data(J, 10) Then
poster(K, 5) = data(J, 5) * data(J, 9) 'beløb sidste år
Else
poster(K, 5) = 0
End If
'*************************************** KABBAK *************************
poster(K, 7) = data(J, 1) 'kontonr.
'poster(K, 8) = data(J, 7) 'kontrolkode til specielle beregninger
'poster(K, 9) = data(J, 8) 'kode
K = K + 1
totaliår = totaliår + data(J, 3) * data(J, 9)
If data(J, 10) = Empty Or data(J, 7) = data(J, 10) Then totalsidsteår = totalsidsteår + data(J, 5) * data(J, 9)
End If
End If
'*************************************** KABBAK ***********************************
If data(J, 10) <> Empty And data(J, 7) <> data(J, 10) Then
If data(J, 10) = Overskrifter(I, 1) Then
If data(J, 3) <> 0 Or data(J, 5) <> 0 Then
poster(K, 1) = data(J, 2) 'tekst/kontonavn
poster(K, 5) = data(J, 5) * data(J, 12) 'beløb i år
poster(K, 7) = data(J, 1) 'kontonr.
poster(K, 3) = 0
K = K + 1
' Totaliår = Totaliår + data(J, 3) * data(J, 12)
totalsidsteår = totalsidsteår + data(J, 5) * data(J, 12)
End If
End If
End If
'**************************************** KABBAK *************************************************
Next J
End If
'Range("B1").Select
Range("B" & rækkestart).Select
sidste = ActiveSheet.Range("B1000").End(xlUp).Row
'<<<< Finder rækkenr. for overskrift >>>>
Do
ActiveCell.End(xlDown).Select
If ActiveCell.Row > sidste Then Exit Do
Loop Until ActiveCell.Value = Overskrifter(I, 2)
rækkestart = ActiveCell.Row
'<<<< Finder rækkenr. for overskrift i alt >>>>
Do
ActiveCell.End(xlDown).Select
If ActiveCell.Row > sidste Then Exit Do
Loop Until ActiveCell.Value = Overskrifter(I, 2) & " i alt "
rækkeslut = ActiveCell.Row
'<<<< Sletter rækker mellem overskrift og i alt >>>>
If rækkeslut - rækkestart > 1 Then
Rows(rækkestart + 1 & ":" & rækkeslut - 1).Delete
End If
'<<<< indsætter rækker og data og totaler mellem overskrift og i alt >>>>
If K > 0 Then
Rows(rækkestart + 1 & ":" & rækkestart + K).Insert shift:=xlShiftDown
Range("A" & rækkestart + 1).Resize(K, 6) = poster
Range("A" & rækkestart + 1).Resize(K, 6).Font.Bold = False
With Range("B" & rækkestart + 1).Resize(K + 1, 1)
.NumberFormat = "@*."
.HorizontalAlignment = xlDistributed
End With
Cells(rækkestart + 1 + K, 4) = totaliår
Cells(rækkestart + 1 + K, 6) = totalsidsteår
If UCase(Overskrifter(I, 3)) = "NEJ" Then
Rows(rækkestart - 1 & ":" & rækkestart + K + 2).Hidden = True
End If
Else
Cells(rækkestart + 1 + K, 4) = 0
Cells(rækkestart + 1 + K, 6) = 0
Rows(rækkestart - 1 & ":" & rækkestart + 2).Hidden = True
End If
'<<<< Nulstiller totaler og tæller inden næste overskrift hentes ind >>>>
K = 0: totaliår = 0: totalsidsteår = 0
Next I
Application.ScreenUpdating = True
Range(Range("F65536").End(xlUp).Address).Select
Application.ScreenUpdating = False
For Each pb In Worksheets("spec1").HPageBreaks
I = pb.Location.Row
If Rows(I).PageBreak = xlPageBreakAutomatic Then
If Cells(I, "I") = "" Then
A = Cells(I, "I").End(xlUp).Row
Rows(A).PageBreak = xlPageBreakManual
End If
End If
Next pb
With Worksheets("spec1").HPageBreaks
I = .Item(.Count).Location.Row
If Rows(I).PageBreak = xlPageBreakAutomatic Then
If Cells(I, "I") = "" Then
A = Cells(I, "I").End(xlUp).Row
Rows(A).PageBreak = xlPageBreakManual
End If
End If
End With
Set Rng = Nothing
Range("A1").Select
Application.ScreenUpdating = True
Application.ScreenUpdating = False
Worksheets("spec1").Activate
Range("a1").Activate
''
'
'
End Sub
