macro bliver langsommere 2. gang den køres
Jeg har en kode der kører rigtig godt første gang den bliver kørt efter min excel fil er blevet åbnet.MEn fra 2. gang og derefter bliver den ca. 4 gange så langsom.
Jeg har forsøgt at nulstille nogle af variablerne til sidst i makroen for at den IKKE skal blive langsommere, men det virker overhovedet ikke.
Makroen kører på en stor maskine med 4 gb ram og quad core processor, så deter ikke umiddelbart hardwaren der er et problem.
Er der nogle af jer "vba-hajer" der kan sige mig om jeg kan nulstille yderligere ting, når makroen er færdig, så jeg undgår at den bliver langsommere.
JEg ved godt at koden ikke lige er til at gennemskue, men jeg håber på at I kan se det overordnede i koden.
Sub Dan_regnskab_specifikation()
' Sub dan_specifikationer()
Dim Poster()
Dim I, J, K, Flyt As Boolean
Dim Rng As Range
Application.ScreenUpdating = False
Worksheets("spec1").Activate
Cells.Rows.Hidden = False
Cells.PageBreak = xlPageBreakNone
With Worksheets("Konto2") 'tilrettes til ark med data
Data = .Range("A2:L" & .Range("B200").End(xlUp).Row + 1)
.Range("C200").End(xlUp).Value = WorksheetFunction.Sum(.Range("C1:C6223")) * -1
.Range("E200").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
If Data(J, 3) <> 0 Or Data(J, 5) <> 0 Then
'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("B500").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
Range(Range("F500").End(xlUp).Address).Select
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
Set overskrifter = Nothing
Set I = Nothing
Set J = Nothing
Set K = Nothing
Set rækkestart = Nothing
Set rækkeslut = Nothing
Set Data = Nothing
Set sidste = Nothing
Range("A1").Select
End Sub
