17. maj 2007 - 19:30Der er
3 kommentarer og 1 løsning
Hjælp til forbedring af en eksisterende vba kode
Jeg har idag en kode der henter nogle tal fra et ark og sætter dem ind i et andet ark i nogle forskellige grupper som bliver defineret i det første ark.
Koden virker rigtig fin, men jeg har brug for at få koden udviddet/forbedret, men kan ikke selv finde ud af det.
Hvad det er koden præsist gør, er temmelig svær at forklare uden at have et direkte eksempel. Jeg har derfor tænkt mig at sende en fil med koden og tallene i, så man kan se hvad det er jeg gerne vil have.
Er der nogen der har mod på at hjælpe mig med at forbedre koden?
Virksomheder er på vej fra store sprogmodeller, der svarer på spørgsmål, til AI-agenter, der kan udføre opgaver på egen hånd. Det gør teknologien mere nyttig – og langt mere risikabel.
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 = "??"
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
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
Takker for nu :-) Håber at det kan lade sig gøre at få de sidste mangler med, senere :-)
Synes godt om
Ny brugerNybegynder
Din løsning...
Tilladte BB-code-tags: [b]fed[/b] [i]kursiv[/i] [u]understreget[/u] Web- og emailadresser omdannes automatisk til links. Der sættes "nofollow" på alle links.
