11. oktober 2007 - 18:10Der er
16 kommentarer og 1 løsning
indsætte linie med overskrift og sammentælling
Kan det lade sig gøre at lave en makro der indsætter nogle linier med overskrifter og sammentællinger.
Jeg har idag en masse linier i et ark. I kolonne A står der nogle forskellige tal i intervallet 1000-9999
Disse linier er hentet ind fra et andet ark og varierer fra gang til gang både i antal linier og de tal der står i linierne.
Nu kunne jeg så godt tænke mig at den lavede/indsatte en linie over den første konto der hedder DRIFT (over den første konto der er større end 999) og en linie der hedder DRIFT I ALT (under den sidste konto der er mindre 4999)
Passiver + passiver i alt (for intervallet 6000-6999)
Andet + Andet i alt(for intervallet 7000-9999)
Nedenfor har jeg forsøgt at illustrerer et eksempel:
SOM DET SER UD NU: kol a kol b kol c kold E 1010 tekst1 100 150 1020 tekst2 2500 4000 5050 tekst3 125000 15000 5800 tekst4 250 250 6100 tekst 5 250000 2500000 6500 tekst 6 2522 2522 7500 tekst 7 1 1
SOM DET ØNSKES: kol a kol b kol c kold E DRIFT 1010 tekst1 100 150 1020 tekst2 2500 4000 DRIFT I ALT 2600 4150
navne = Array("Drift", "Aktiver", "Passiver", "Andet1", "Andet2", "Andet3", "Andet4") tabel(0) = 5 ' start offset i tabel Application.ScreenUpdating = False lastrow = ActiveSheet.Cells(ActiveSheet.Rows.Count, 1) _ .End(xlUp).Offset(1, 0).Row - 1 For c = 1 To 7 tabel(c) = 0 Next c
For r = tabel(0) + 1 To lastrow If (Range("A" & r).Value < 5000) Then driftrow = r tabel(1) = r Else If (Range("A" & r).Value < 6000) Then aktiverrow = r tabel(2) = r Else If (Range("A" & r).Value < 7000) Then passiverrow = r tabel(3) = r Else If (Range("A" & r).Value < 8000) Then andet1row = r tabel(4) = r Else If (Range("A" & r).Value < 9000) Then andet2row = r tabel(5) = r Else If (Range("A" & r).Value < 9500) Then andet3row = r tabel(6) = r Else If (Range("A" & r).Value < 10000) Then andet4row = r tabel(7) = r End If End If End If End If End If End If End If Next r
tabeltl = 7
Do If (tabel(tabeltl) > 0) Then Rows(tabel(tabeltl) + 1 & ":" & tabel(tabeltl) + 1).Select Selection.Insert Shift:=xlDown Range("A" & tabel(tabeltl) + 1).Value = navne(tabeltl - 1) & " IALT" Rows(tabel(tabeltl) + 1 & ":" & tabel(tabeltl) + 1).Select With Selection.Font .FontStyle = "bold" End With c = 1 ' find forrige If (tabeltl > 1) Then Do If (tabel(tabeltl - c) > 0) Then Exit Do End If c = c + 1 Loop Until tabel(tabeltl - c) > 0 End If Range("C" & tabel(tabeltl) + 1).Value = "=SUM(C" & tabel(tabeltl - c) + 1 & ":C" & tabel(tabeltl) & ")" Range("D" & tabel(tabeltl) + 1).Value = "=SUM(D" & tabel(tabeltl - c) + 1 & ":D" & tabel(tabeltl) & ")"
ja, det er faktisk temmelig langt derhen af. men der er lidt småproblemer.....
1. Det første og midste problem er at sammen tallene er i kolonne C 0g E.
2. Når den laver linierne drift ialt, aktiver ialt osv. tæller den korrekt sammen og indsætter en linie, der hvor den skal. Men overskrifterne DRIFT, AKTIVER, osv. blier ALTID indsat 2 linier over sammentællingen. Det duer ikke. Der er typisk 20 linier i hver grupper og dette kan variere. Overskriften "Drift" skal derfor indsættes over det første tal der >1000 AKTIVER skal indsættes lige over det første tal der > 5000 osv.
så prøv denne, jeg havde tilfældigvis kun 2tal i hver af mine grupper, så det så fint ud os mig. :-)
Dim tabel(8) As Variant
navne = Array("Drift", "Aktiver", "Passiver", "Andet1", "Andet2", "Andet3", "Andet4") tabel(0) = 5 ' start offset i tabel Application.ScreenUpdating = False lastrow = ActiveSheet.Cells(ActiveSheet.Rows.Count, 1) _ .End(xlUp).Offset(1, 0).Row - 1 ' find sidste række For c = 1 To 7 tabel(c) = 0 Next c
For r = tabel(0) + 1 To lastrow If (Range("A" & r).Value < 5000) Then tabel(1) = r Else If (Range("A" & r).Value < 6000) Then tabel(2) = r Else If (Range("A" & r).Value < 7000) Then tabel(3) = r Else If (Range("A" & r).Value < 8000) Then tabel(4) = r Else If (Range("A" & r).Value < 9000) Then tabel(5) = r Else If (Range("A" & r).Value < 9500) Then tabel(6) = r Else If (Range("A" & r).Value < 10000) Then tabel(7) = r End If End If End If End If End If End If End If Next r
tabeltl = 7
Do If (tabel(tabeltl) > 0) Then Rows(tabel(tabeltl) + 1 & ":" & tabel(tabeltl) + 1).Select ' sæt bundlinie Selection.Insert Shift:=xlDown With Selection.Font .FontStyle = "bold" End With Range("A" & tabel(tabeltl) + 1).Value = navne(tabeltl - 1) & " IALT" c = 1 ' find forrige række If (tabeltl > 1) Then Do If (tabel(tabeltl - c) > 0) Then Exit Do End If c = c + 1 Loop Until tabel(tabeltl - c) > 0 End If Range("C" & tabel(tabeltl) + 1).Value = "=SUM(C" & tabel(tabeltl - c) + 1 & ":C" & tabel(tabeltl) & ")" Range("D" & tabel(tabeltl) + 1).Value = "=SUM(E" & tabel(tabeltl - c) + 1 & ":E" & tabel(tabeltl) & ")"
Rows(tabel(tabeltl - c) + 1 & ":" & tabel(tabeltl - c) + 1).Select ' sæt overskrift Selection.Insert Shift:=xlDown With Selection.Font .FontStyle = "bold" End With Range("A" & tabel(tabeltl - c) + 1).Value = navne(tabeltl - 1) Rows(tabel(tabeltl - c) + 1 & ":" & tabel(tabeltl - c) + 1).Select ' ekstra linie Selection.Insert Shift:=xlDown
End If tabeltl = tabeltl - 1
Loop Until tabeltl = 0 Application.ScreenUpdating = True
Yes, nu virker den. Mange tak for hjælpen. Hvis du har et svar, så har jeg points.
Jeg har dog en lille tilrettelse som kunne være rigtig godt at få med. Nogle gange er der tomme linier (aldrig mere end 1 tom linie) mellem nogle af de linier som er importeret. Når dette er tilfældet virker den ikke, men jeg kan ikke selv overskue hvor rettelsen skal laves.
navne = Array("Drift", "Aktiver", "Passiver", "Andet1", "Andet2", "Andet3", "Andet4") tabel(0) = 5 ' start offset i tabel Application.ScreenUpdating = False lastrow = ActiveSheet.Cells(ActiveSheet.Rows.Count, 1) _ .End(xlUp).Offset(1, 0).Row - 1 ' find sidste række For c = 1 To 7 tabel(c) = 0 Next c
For r = tabel(0) + 1 To lastrow If ((Range("A" & r).Value < 5000) And (Range("A" & r).Value <> Empty)) Then tabel(1) = r Else If ((Range("A" & r).Value < 6000) And (Range("A" & r).Value <> Empty)) Then tabel(2) = r Else If ((Range("A" & r).Value < 7000) And (Range("A" & r).Value <> Empty)) Then tabel(3) = r Else If ((Range("A" & r).Value < 8000) And (Range("A" & r).Value <> Empty)) Then tabel(4) = r Else If ((Range("A" & r).Value < 9000) And (Range("A" & r).Value <> Empty)) Then tabel(5) = r Else If ((Range("A" & r).Value < 9500) And (Range("A" & r).Value <> Empty)) Then tabel(6) = r Else If ((Range("A" & r).Value < 10000) And (Range("A" & r).Value <> Empty)) Then tabel(7) = r End If End If End If End If End If End If End If Next r
tabeltl = 7
Do If (tabel(tabeltl) > 0) Then Rows(tabel(tabeltl) + 1 & ":" & tabel(tabeltl) + 1).Select ' sæt bundlinie Selection.Insert Shift:=xlDown With Selection.Font .FontStyle = "bold" End With Range("A" & tabel(tabeltl) + 1).Value = navne(tabeltl - 1) & " IALT" c = 1 ' find forrige række If (tabeltl > 1) Then Do If (tabel(tabeltl - c) > 0) Then Exit Do End If c = c + 1 Loop Until tabel(tabeltl - c) > 0 End If Range("C" & tabel(tabeltl) + 1).Value = "=SUM(C" & tabel(tabeltl - c) + 1 & ":C" & tabel(tabeltl) & ")" Range("D" & tabel(tabeltl) + 1).Value = "=SUM(E" & tabel(tabeltl - c) + 1 & ":E" & tabel(tabeltl) & ")"
Rows(tabel(tabeltl - c) + 1 & ":" & tabel(tabeltl - c) + 1).Select ' sæt overskrift Selection.Insert Shift:=xlDown With Selection.Font .FontStyle = "bold" End With Range("A" & tabel(tabeltl - c) + 1).Value = navne(tabeltl - 1) Rows(tabel(tabeltl - c) + 1 & ":" & tabel(tabeltl - c) + 1).Select ' ekstra linie Selection.Insert Shift:=xlDown
End If tabeltl = tabeltl - 1
Loop Until tabeltl = 0 Application.ScreenUpdating = True
Du får lige en ny, den forrige sætter en tom linie ind i starten,
Dim tabel(8) As Variant Const start_linie = 6
navne = Array("Drift", "Aktiver", "Passiver", "Andet1", "Andet2", "Andet3", "Andet4") Application.ScreenUpdating = False lastrow = ActiveSheet.Cells(ActiveSheet.Rows.Count, 1) _ .End(xlUp).Offset(1, 0).Row - 1 ' find sidste række tabel(0) = start_linie - 1 ' start offset i tabel For c = 1 To 7 ' clear tabel tabel(c) = 0 Next c
For r = tabel(0) + 1 To lastrow If ((Range("A" & r).Value < 5000) And (Range("A" & r).Value <> Empty)) Then tabel(1) = r Else If ((Range("A" & r).Value < 6000) And (Range("A" & r).Value <> Empty)) Then tabel(2) = r Else If ((Range("A" & r).Value < 7000) And (Range("A" & r).Value <> Empty)) Then tabel(3) = r Else If ((Range("A" & r).Value < 8000) And (Range("A" & r).Value <> Empty)) Then tabel(4) = r Else If ((Range("A" & r).Value < 9000) And (Range("A" & r).Value <> Empty)) Then tabel(5) = r Else If ((Range("A" & r).Value < 9500) And (Range("A" & r).Value <> Empty)) Then tabel(6) = r Else If ((Range("A" & r).Value < 10000) And (Range("A" & r).Value <> Empty)) Then tabel(7) = r End If End If End If End If End If End If End If Next r
tabeltl = 7
Do If (tabel(tabeltl) > 0) Then Rows(tabel(tabeltl) + 1 & ":" & tabel(tabeltl) + 1).Select ' sæt bundlinie Selection.Insert Shift:=xlDown With Selection.Font .FontStyle = "bold" End With Range("A" & tabel(tabeltl) + 1).Value = navne(tabeltl - 1) & " IALT" Rows(tabel(tabeltl) + 2 & ":" & tabel(tabeltl) + 2).Select ' ekstra linie Selection.Insert Shift:=xlDown c = 1 ' find forrige række If (tabeltl > 1) Then Do If (tabel(tabeltl - c) > 0) Then Exit Do End If c = c + 1 Loop Until tabel(tabeltl - c) > 0 End If Range("C" & tabel(tabeltl) + 1).Value = "=SUM(C" & tabel(tabeltl - c) + 1 & ":C" & tabel(tabeltl) & ")" Range("D" & tabel(tabeltl) + 1).Value = "=SUM(E" & tabel(tabeltl - c) + 1 & ":E" & tabel(tabeltl) & ")"
Rows(tabel(tabeltl - c) + 1 & ":" & tabel(tabeltl - c) + 1).Select ' sæt overskrift Selection.Insert Shift:=xlDown With Selection.Font .FontStyle = "bold" End With Range("A" & tabel(tabeltl - c) + 1).Value = navne(tabeltl - 1)
End If tabeltl = tabeltl - 1
Loop Until tabeltl = 0 Application.ScreenUpdating = True
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.
