Rette i kode MOD BETALING
ER DER NOGEN DER VIL HJÆLPE MIG MOD BETALING?JEg har en eksisterende kode som I hajer løbende har hjulpet mig med. Den laver en mindre fejl pt.
Denne fejl er jeg næsten sikker på at jeg har lokaliseret. Men jeg kan ikke finde uda af rette den. Jeg har markeret de 2 steder der laver fejlen neden for og igen i selve koden.
Det den første stump gør at fange det nr. der står i "I,2" og gemmer det som "Kontonr"
Det kontonr. sætter den så ind i det lille stykke kode nedenfor.
Det er fint så længe der ikke står flere forskellige tal i (I,2)
Hvis der står forskellige tal, husker den kun den første og sætter det samme tal ind igen og igen.
"Kontonr" skal altså være forskellig for hver gang der står noget i (I,2), men det kan jeg ikke hitte ud af.
Er der nogen der kan forstå / spotte mig problem.
JEG SENDER SELVFØLGELIG GERNE MIT ARK TIL JER SÅ I KAN SE HVOR FEJLEN ER. DEN ER NEMLIG MEGET LET AT SPOTTE; NÅR FØRST I FÅR ARKET
'***OBS****OBS****OBS***OBS*********************************
If Tjek(I, 1) = Tjek(Y, 2) Then
OK = True
If Tjek(I, 2) <> "" Then
Kontonr = Data(I, 1)
End If
'***OBS****OBS****OBS***OBS*********************************
'***OBS****OBS****OBS***OBS*********************************
Data(NR + X, 1) = Kontonr '****** SAMLER PÅ DET KONTONR SOM STYRER
'***OBS****OBS****OBS***OBS*********************************
Sub Dan_regnskab_specifikation2()
Dim Data As Variant, I As Integer, X As Integer, SumPoster As Variant, ErDerSumposter As Boolean, RK As Integer
Dim NR As Integer, Antal() As Variant, T As Integer, N As Integer, RækkeStart As Integer, OV As Variant, Tid As Date
Dim MinRækker As Integer
ActiveSheet.PageSetup.PrintArea = ""
ErDerSumposter = False
RK = 0
Application.Calculation = xlCalculationManual ' stopper automatisk udregning af formler
Application.ScreenUpdating = False
With Worksheets("Konto")
MinRækker = Worksheets("stam").Range("antal_linier_for_autoskjul") ' Minimum rækker excl overskrift og total
' Tjekker om der valgt overskrifter, det skal være det samme i N og O kolonnen
Data = .Range("A5:P" & .Range("B65536").End(xlUp).Row + 50) ' indlæser kontoplan i variablen Data + 50 tomme rækker
Tjek = .Range("N5:O" & .Range("B65536").End(xlUp).Row)
.Range("C200").End(xlUp).Value = WorksheetFunction.Sum(.Range("C1:C200")) * -1
.Range("E200").End(xlUp).Value = WorksheetFunction.Sum(.Range("E1:E200")) * -1
With Worksheets("overskrift") 'tilrettes til ark med overskrifter
Overskrifter = .Range("A2:C" & .Range("B200").End(xlUp).Row)
End With
SidsteData = UBound(Data)
For I = 1 To UBound(Tjek)
OK = False
For Y = 1 To UBound(Tjek)
If Not IsEmpty(Tjek(I, 1)) Then
'***OBS****OBS****OBS***OBS*********************************
If Tjek(I, 1) = Tjek(Y, 2) Then
OK = True
If Tjek(I, 2) <> "" Then
Kontonr = Data(I, 1)
End If
'***OBS****OBS****OBS***OBS*********************************
Exit For
End If
Else
OK = True
End If
Next
If Not OK Then
Application.ScreenUpdating = True
Application.Calculation = xlCalculationManual ' starter automatisk udregning af formler
MsgBox "Du har glemt at angive nr i kolonne O i linien(" & .Range("O" & I + 4).Offset(0, -14) & " " & .Range("O" & I + 4).Offset(0, -13) & ")"
Exit Sub
End If
Next
End With
With Worksheets("overskrift") 'tilrettes til ark med overskrifter
Overskrifter = .Range("A2:C" & .Range("B200").End(xlUp).Row)
End With
K1 = 0 ' nulstiller antal samledata
For I = 1 To UBound(Data)
If IsEmpty(Data(I, 7)) And IsEmpty(Data(I, 10)) Then
If RK = 0 Then RK = I ' første række der er ledig i Variablen Data
For X = 1 To UBound(Data, 2)
Data(I, X) = Empty ' sletter data der ikke har et specnr
Next
Else
Data(I, 3) = Data(I, 3) * Data(I, 9) ' ganger beløbet
If IsEmpty(Data(I, 10)) Then ' hvis faktor for sidste år er tom, bruges dette år
Data(I, 5) = Data(I, 5) * Data(I, 9) ' ganger beløbet Sidste år med faktor i år
Else
Data(I, 5) = Data(I, 5) * Data(I, 12) ' ganger beløbet Sidste år med faktor Sidste år
End If
End If
Next
SidsteData = RK - 1
NR = RK
For I = 1 To SidsteData
If Not IsEmpty(Data(I, 7)) And Not IsEmpty(Data(I, 10)) Then
For X = 1 To UBound(Data, 2)
Data(NR, X) = Data(I, X)
Next
Data(NR, 3) = 0
Data(I, 5) = 0
Data(NR, 7) = Data(I, 10) * 100
If Not IsEmpty(Data(I, 15)) Then Data(NR, 15) = Data(I, 15) * 100 ' specnr* 100, på dem der skal adskilles, for sidste år
Data(NR, 14) = Data(I, 14) * 100 ' specnr* 100, på dem der skal adskilles, for sidste år
NR = NR + 1
End If
If Not IsEmpty(Data(I, 16)) Then Data(I, 2) = Data(I, 16) & " "
Next
Sheets.Add
ActiveSheet.Name = "TEMP" ' bruger et midlertidig ark til sortering
Range("A1").Resize(UBound(Data, 1), UBound(Data, 2)) = Data
Range("A1").Select
Range(Selection, ActiveCell.SpecialCells(xlLastCell)).Select
Selection.Sort Key1:=Range("G1"), Order1:=xlAscending, Key2:=Range("A1") _
, Order2:=xlAscending, Header:=xlGuess, OrderCustom:=1, MatchCase:= _
False, Orientation:=xlTopToBottom, DataOption1:=xlSortNormal, DataOption2 _
:=xlSortNormal
Data = Range("A1").Resize(NR + 50, UBound(Data, 2))
Application.DisplayAlerts = False
ActiveSheet.Delete
Application.DisplayAlerts = True
SidsteData = NR
For I = 1 To SidsteData
If Not IsEmpty(Data(I, 15)) Then
K1 = K1 + 1 ' tæller antal samledata
ReDim Preserve Antal(K1)
Antal(K1) = Data(I, 15)
ErDerSumposter = True
End If
Next
If ErDerSumposter Then
For X = 1 To UBound(Antal)
For I = 1 To SidsteData
If Antal(X) = Data(I, 14) Then ' passer sammentællingskoden, så fortsæt
If Not IsEmpty(Data(I, 16)) Then ' er der special overskrift
Data(NR + X, 2) = Data(I, 16) & " " ' special Overskrift
ElseIf Not IsEmpty(Data(I, 15)) Then ' eller er der et tal ud for en anden
Data(NR + X, 2) = Data(I, 2) ' normal Overskrift
End If
'***OBS****OBS****OBS***OBS*********************************
Data(NR + X, 1) = Kontonr '****** SAMLER PÅ DET KONTONR SOM STYRER
'***OBS****OBS****OBS***OBS*********************************
Data(NR + X, 3) = Data(NR + X, 3) + Data(I, 3) ' summere dette år
Data(NR + X, 5) = Data(NR + X, 5) + Data(I, 5) ' summere sidste år
Data(NR + X, 7) = Data(I, 7) ' specnr
For T = 1 To UBound(Data, 2)
Data(I, T) = Empty ' sletter data efter summering
Next
End If
Next
Next
End If
For X = 1 To UBound(Data)
If Data(X, 7) > 100 Then Data(X, 7) = Data(X, 7) / 100 ' Retter specnr, på dem der skal adskilles, for sidste år
Next
Sheets.Add ' bruger et midlertidig ark til sortering
ActiveSheet.Name = "TEMP1"
Range("A1").Resize(UBound(Data, 1), UBound(Data, 2)) = Data
Range("A1").Select
Range(Selection, ActiveCell.SpecialCells(xlLastCell)).Select
Selection.Sort Key1:=Range("G1"), Order1:=xlAscending, Key2:=Range("A1") _
, Order2:=xlAscending, Header:=xlGuess, OrderCustom:=1, MatchCase:= _
False, Orientation:=xlTopToBottom, DataOption1:=xlSortNormal, DataOption2 _
:=xlSortNormal
Application.DisplayAlerts = False
Data = Range("A1:G" & Range("B65536").End(xlUp).Row)
ActiveSheet.Delete
Application.DisplayAlerts = True
Worksheets("spec1").Activate
With Worksheets("spec1")
Cells.Rows.Hidden = False
ActiveSheet.DisplayPageBreaks = True
For I = 2 To .Range("B1000").End(xlUp).Row
Rows(I).PageBreak = xlPageBreakNone ' fjerner sideskift
' Rows(I).PageBreak = xlNone
Next
ActiveSheet.DisplayPageBreaks = False
SidsteData = UBound(Data)
RækkeStart = 4
Application.ScreenUpdating = False
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) 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 Exit For
If Data(J, 7) = 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, 3) = Data(J, 3) 'beløb i år
Poster(K, 5) = Data(J, 5) 'beløb sidste år
Poster(K, 7) = Data(J, 1) 'kontonr.
K = K + 1
totaliår = totaliår + Data(J, 3)
totalsidsteår = totalsidsteår + Data(J, 5)
End If
End If
Next J
End If
OV = Worksheets("spec1").Range("B6:B" & Worksheets("spec1").Range("B1000").End(xlUp).Row)
For Y = UBound(OV) To 1 Step -1
If OV(Y, 1) = Overskrifter(I, 2) And .Cells(Y + 5, "I") = Overskrifter(I, 1) Then
RækkeStart = Y + 5 '<<<< Finder rækkenr. for overskrift >>>>
Exit For
End If
If OV(Y, 1) = Overskrifter(I, 2) & " i alt " And .Cells(Y + 5, "I") = Overskrifter(I, 1) Then Rækkeslut = Y + 5 '<<<< Finder rækkenr. for overskrift i alt >>>>
Next
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
'Den må altså ikke skjule grupperne 1-13 og 69-74, da
Select Case Overskrifter(I, 1)
Case 1 To 13, 69 To 74
Case Else
If K + 2 <= MinRækker + 2 Then
.Rows(RækkeStart - 1 & ":" & RækkeStart + K + 2).Hidden = True
End If
End Select
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
Application.StatusBar = "Danner SPECIFIKATION " & I & " af " & UBound(Overskrifter)
Next I
Application.Calculation = xlCalculationManual ' stopper automatisk udregning af formler
Calculate
ActiveSheet.DisplayPageBreaks = True
Application.ScreenUpdating = True ' slår opdatering af skærmen til igen
End With
End Sub
