Zeilen einfügen nach Gruppe und Summe

Hallo kniffeliges Problem,
https://www.herber.de/bbs/user/35879.xls
Mache jetzt alle Manuell kann man dass über VBA vereinfachen.
Blatt wird über mehrere andere Blätter hergestellt .
In Rechnung müsse Zeilen eingefugt werden nach 2 Kriterien Ländergruppe zähle 1 bis 25 das sind alle EEG länden, und jede einzelne zahl höher dann 25 ist ein andereres Land unter diese beide Gruppen muss eine Zeile eingefugt werden.
Summe, Gewicht je Gruppe muss nach Möglichkeit summiert werden.
Länder Gruppe anderen je Rechnung
Zum Erklärung bitte Anhang sehn
Rechnung kann Zeilen von 29 bis 2525 Positionen erfassen alle nicht benötigte Zeilen werden ausgeblendet.
Wenn überhaupt möglich Muss eine Zeile mit Text Drittlandswaren eingefügt werden.
Gruße
Karel

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Sub Bearbeiten() Dim i As Integer 'ersteinmal EU, letzte EU-Zeile ermitteln For i = 29 To Range("A65536").End(xlUp).Row If Range("Z" & i) > 25 Then Exit For Next i Call Summenbildung(i) Call Rahmen(i) i = i + 1 'Die Überschrift für Drittland Rows(i).Insert Shift:=xlDown Rows(i).Font.Bold = True Range("B" & i) = "Drittlandware" Range("B" & i).Font.Size = 10 Call Rahmen(i) 'Die Gruppen der restl.Länder i = i + 2 While Range("Z" & i) > 25 'Gruppenwechsel suchen If Range("Z" & i) <> Range("Z" & i - 1) Then Call Summenbildung(i) Call Rahmen(i) i = i + 1 'wegen eingefügter Summenzeile End If i = i + 1 Wend End Sub

Sub Summenbildung(i As Integer) 'Zeile einfügen, Schrift fett Rows(i).Insert Shift:=xlDown Rows(i).Font.Bold = True 'Zeilennummer der ersten Zelle für die Summierung ermitteln x = Range("Z" & i - 1).CurrentRegion.Address svon = Mid(Right(x, Len(x) - 3), 1, InStr(Right(x, Len(x) - 3), ":") - 1) 'alle betroffenen Spalten mit Summenformel bestücken For Each Spalte In Array("J", "N", "P", "T") Range(Spalte & i).Formula = "=SUM(" & Spalte & svon & ":" & Spalte & i - 1 & ")" Next End Sub

Sub Rahmen(i As Integer) 'Rahmen für betroffene Zeile setzen: innen nix, außen dünn Range("A" & i & ":V" & i).Borders(xlInsideVertical).LineStyle = xlNone For Each Wert In Array(xlEdgeLeft, xlEdgeTop, xlEdgeBottom, xlEdgeRight) With Range("A" & i & ":V" & i).Borders(Wert) .LineStyle = xlContinuous .Weight = xlThin End With Next Wert End Sub

Sub Bearbeiten() Dim i As Integer Sheets("Orginal").Copy 'neue Datei erzeugen 'ersteinmal EU, letzte EU-Zeile ermitteln For i = 29 To Range("A65536").End(xlUp).Row If Range("Z" & i) > 25 Then Exit For Next i Call Summenbildung(i) Call Rahmen(i) i = i + 1 'Die Überschrift für Drittland Rows(i).Insert Shift:=xlDown Rows(i).Font.Bold = True Range("B" & i) = "Drittlandware" Range("B" & i).Font.Size = 10 Call Rahmen(i) 'Die Gruppen der restl.Länder i = i + 2 While Range("Z" & i) > 25 'Gruppenwechsel suchen If Range("Z" & i) <> Range("Z" & i - 1) Then Call Summenbildung(i) Call Rahmen(i) i = i + 1 'wegen eingefügter Summenzeile End If i = i + 1 Wend End Sub

Sub Summenbildung(bis As Integer) 'Zeile einfügen, Schrift fett Rows(bis).Insert Shift:=xlDown Rows(bis).Font.Bold = True 'Zeilennummer der ersten Zelle für die Summierung ermitteln x = Range("Z" & bis - 1).CurrentRegion.Address von = Mid(Right(x, Len(x) - 3), 1, InStr(Right(x, Len(x) - 3), ":") - 1) 'alle betroffenen Spalten mit Summenformel bestücken For Each Spalte In Array("J", "N", "P", "T") Range(Spalte & bis) = _ Application.WorksheetFunction.Sum(Range(Spalte & von & ":" & Spalte & bis - 1)) Next 'alle betroffenen Spalten: Gesamtsumme erweitern Set gzelle = Columns("C:C").Find(What:="gesamt", LookIn:=xlValues, LookAt:=xlWhole, _ SearchDirection:=xlNext, MatchCase:=False) For Each Spalte In Array("J", "N", "P", "T") Range(Spalte & gzelle.Row) = Range(Spalte & gzelle.Row) + Range(Spalte & bis) Next Set gzelle = Nothing End Sub

hallo Karel,
das Programm ist so geschrieben, dass es den Bedingungen Deiner Tabelle vom Donnerstag (13:44) entspricht.
Falls es nun nicht läuft, liegt es entweder daran, dass Du die Tabelle verändert hast, oder an unterschiedlichen Excel-Versionen. Da das Programm in der letzten Version (ohne Copy, ohne Gesamtsumme) lief, gehe ich von ersterem aus (die Tabelle hat sich geändert).
Das Programm erwartet, dass:
- das betroffene Tabellenblatt "Original" heißt
- die Datensätze in Zeile 29 beginnen
- die Ländercodes in Spalte Z stehen
- irgendwo in Spalte B "Gesamt" steht
- die zu summierende Spalten J, N, P und T sind
- ...
Wenn Deine Datei diesen Bedingungen nicht entspricht läuft das Programm falsch oder gar nicht und es gibt zwei Möglichkeiten:
- 1. Du passt Die Datei den Bedingungen an
- 2. Du passt das Programm an (z.B.: Sheets("Orginal").Copy --> Sheets("xxx").Copy)
Wenn sich die Bedingungen ändern können, ist das Programm generell variable zu gestalten. Also etwa so:
- ermittle das Tabellenblatt, das die Daten beinhaltet anhand von Kriterien...
- ermittle die Spalte der Ländercodes indem Du die Spaltenüberschrift "Ursprungsland" suchst.
- usw.
Es könnte sein, dass Du Fehler 91 bekommen hast, weil Dir die Zelle mit "Gesamt" in Spalte B fehlte. Für diesen Fall habe ich das Programm geändert, "Gesamt" wird jetzt erzeugt, wenn es nicht vorhanden ist.
Also: kopiere den neuen Code in Deine Datei und probier, ob es läuft. Wenn nicht, nimm die Datei von Donnerstag und kopiere den Code dort hinein. Wenn es dort nicht läuft, melde Dich wieder - andernfalls passe Deine (geänderte) Tabelle so an, dass sie den Bedingungen von Donnerstag entspricht.
Was meist Du eigentlich mit: "Verknüpfungen löschen"? sind denn in der Kopie noch Verknüpfungen enthalten?
viele Grüße. Heide
hier der geänderte Code:


Sub Bearbeiten()
Dim i As Integer
Sheets("Orginal").Copy        'neue Datei erzeugen
'Gesamtsumme bilden
Set gzelle = Columns("C:C").Find(What:="Gesamt", LookIn:=xlValues, LookAt:=xlWhole, _
SearchDirection:=xlNext, MatchCase:=False)
If gzelle Is Nothing Then
i = Range("A65536").End(xlUp).Row + 1
Range("C" & i) = "Gesamt"
Rows(i).Font.Bold = True
Else: i = gzelle.Row
End If
For Each Spalte In Array("J", "N", "P", "T")
Range(Spalte & i) = Application.WorksheetFunction.Sum(Range(Spalte & "29:" & Spalte & i))
Next
Set gzelle = Nothing
'ersteinmal EU, letzte EU-Zeile ermitteln
For i = 29 To Range("A65536").End(xlUp).Row
If Range("Z" & i) > 25 Then Exit For
Next i
Call Summenbildung(i)
Call Rahmen(i)
i = i + 1
'Die Überschrift für Drittland
Rows(i).Insert Shift:=xlDown
Rows(i).Font.Bold = True
Range("B" & i) = "Drittlandware"
Range("B" & i).Font.Size = 10
Call Rahmen(i)
'Die Gruppen der restl.Länder
i = i + 2
While Range("Z" & i) > 25
'Gruppenwechsel suchen
If Range("Z" & i) <> Range("Z" & i - 1) Then
Call Summenbildung(i)
Call Rahmen(i)
i = i + 1          'wegen eingefügter Summenzeile
End If
i = i + 1
Wend
End Sub


Sub Summenbildung(bis As Integer)
'Zeile einfügen, Schrift fett
Rows(bis).Insert Shift:=xlDown
Rows(bis).Font.Bold = True
'Zeilennummer der ersten Zelle für die Summierung ermitteln
x = Range("Z" & bis - 1).CurrentRegion.Address
von = Mid(Right(x, Len(x) - 3), 1, InStr(Right(x, Len(x) - 3), ":") - 1)
'alle betroffenen Spalten mit Summenformel bestücken
For Each Spalte In Array("J", "N", "P", "T")
Range(Spalte & bis) = _
Application.WorksheetFunction.Sum(Range(Spalte & von & ":" & Spalte & bis - 1))
Next
End Sub


Sub Rahmen(i As Integer)
'Rahmen für betroffene Zeile setzen: innen nix, außen dünn
Range("A" & i & ":V" & i).Borders(xlInsideVertical).LineStyle = xlNone
For Each Wert In Array(xlEdgeLeft, xlEdgeTop, xlEdgeBottom, xlEdgeRight)
With Range("A" & i & ":V" & i).Borders(Wert)
.LineStyle = xlContinuous
.Weight = xlThin
End With
Next Wert
End Sub

Beliebteste Forumthreads (12 Monate)

Zeilen einfügen nach Gruppe und Summe

10
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

299 Forumthreads zu ähnlichen Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

Zeilen einfügen nach Gruppe und Summe

10 Beiträge zum Forumthread Beiträge zu diesem Forumthread

299 Forumthreads zu ähnlichen Themen

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

10
Beiträge zum Forumthread

Beiträge zu diesem Forumthread