Live-Forum - Die aktuellen Beiträge
Anzeige
Archiv - Navigation
1632to1636
Aktuelles Verzeichnis
Verzeichnis Index
Übersicht Verzeichnisse
Vorheriger Thread
Rückwärts Blättern
Nächster Thread
Vorwärts blättern
Anzeige
HERBERS
Excel-Forum (Archiv)
20+ Jahre Excel-Kompetenz: Von Anwendern, für Anwender
Inhaltsverzeichnis

VBA Überschrift über Absätze

VBA Überschrift über Absätze
18.07.2018 16:16:14
Jan
Hallo,
ich brauch mal wieder eure Hilfe.
Ich möchte das über verschiedene Absätze in der Tabelle eine Überschrift gesetzt wird.
Das funktioniert auch alles perfekt, bis auf die letzte Zeile des letzten Absatzes.
Hier wird immer die Überschrift im letzten Absatz in die vorletzte Zeile geschrieben. Und auch das Summieren wird im letzten Absatz gemacht.
Könnt ihr mir sagen warum?
hier der Teil des Codes:
Dim rng As Range
Dim rngRow As Long
Dim First As Long
Dim Last As Long
With ActiveSheet
Last = .Cells(Rows.Count, 1).End(xlUp).Row
Do
First = .Cells(Last, 1).End(xlUp).Row
.Cells(Last + 1, 10).FormulaLocal = "=Summe(J" & First & ":J" & Last & ")"
.Cells(Last + 1, 11).FormulaLocal = "=Summe(K" & First & ":K" & Last & ")"
.Cells(Last + 1, 12).FormulaLocal = "=Summe(L" & First & ":L" & Last & ")"
.Cells(Last + 1, 13).FormulaLocal = "=Summe(M" & First & ":M" & Last & ")"
.Cells(Last + 1, 14).FormulaLocal = "=Summe(N" & First & ":N" & Last & ")"
.Cells(Last + 1, 15).FormulaLocal = "=Summe(O" & First & ":O" & Last & ")"
Vielen Dank

5
Beiträge zum Forumthread
Beiträge zu diesem Forumthread

Betreff
Datum
Anwender
Anzeige
Bitte den vollständigen Code für die genannte
18.07.2018 16:49:26
Daniel
Aufgabenstellung zeigen (ansonsten wäre die erste Frage, wo kommt das Loop für das Do, und steht noch was dazwischen?
wie sieht die Tabelle aus?
prinizpell muss man sagen, dass du dir zuviel arbeit machst.
Die Formeln sind ja für alle Spalten einer zeile gleich, daher kann man sie auch in einem rutsch eintragen.
also statt:
Cells(Last + 1, 10).FormulaLocal = "=Summe(J" & First & ":J" & Last & ")"
.Cells(Last + 1, 11).FormulaLocal = "=Summe(K" & First & ":K" & Last & ")"
.Cells(Last + 1, 12).FormulaLocal = "=Summe(L" & First & ":L" & Last & ")"
.Cells(Last + 1, 13).FormulaLocal = "=Summe(M" & First & ":M" & Last & ")"
.Cells(Last + 1, 14).FormulaLocal = "=Summe(N" & First & ":N" & Last & ")"
.Cells(Last + 1, 15).FormulaLocal = "=Summe(O" & First & ":O" & Last & ")"

reicht:
.Cells(Last + 1, 10).Resize(1, 6).FormulaLocal = "=Summe(J" & First & ":J" & Last & ")"

Excel passt dann die relativen Zellebezüge schon richtig an.
Gruß Daniel
Anzeige
AW: Bitte den vollständigen Code für die genannte
19.07.2018 07:31:14
Jan
Hallo,
danke.
Anbei der komplette Code:
Sub Kopieren()
ActiveWorkbook.Save 'Speichern in die Grunddatei
Range("A1:AV400").Select
Selection.Copy
Selection.PasteSpecial Paste:=xlValues, Operation:=xlNone, SkipBlanks:= _
False, Transpose:=False
ActiveWindow.SmallScroll ToRight:=-1
'gelbe Zellen werden automatisch geloescht
Dim bereich As Range
Set bereich = ActiveSheet.UsedRange
ende = bereich.Rows.Count
For i = ende To 1 Step -1
If Cells(i, 1).Interior.ColorIndex = 6 Then
Rows(i).Delete Shift:=xlUp
End If
Next
' Beide Button werden geloescht
Range("A3").Select
Selection.ClearContents
ActiveSheet.Shapes.Range(Array("Button 1")).Select
Selection.Delete
ActiveSheet.Shapes.Range(Array("Button 3")).Select
Selection.Delete
'Auswahl Spalten entfernen die nicht gebraucht werden
Dim lngSpalte As Long
For lngSpalte = 47 To 39 Step -1
If Cells(3, lngSpalte).Text = "" Then
Columns(lngSpalte).Delete
End If
Next
' Spalten Sortieren
Range("A4:AU400").Select
ActiveWorkbook.Worksheets("Auflagenliste").Sort.SortFields.Clear
ActiveWorkbook.Worksheets("Auflagenliste").Sort.SortFields.Add Key:=Range( _
"A5:A400"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
xlSortNormal
ActiveWorkbook.Worksheets("Auflagenliste").Sort.SortFields.Add Key:=Range( _
"B5:B400"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
xlSortNormal
With ActiveWorkbook.Worksheets("Auflagenliste").Sort
.SetRange Range("A4:AU400")
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
' Zeilen Aufteilen und 3 Zeilen als Trennung hinzufuegen
' Leerzeilen einfuegen
For Zeile = Cells(Rows.Count, 2).End(xlUp).Row To 2 Step -1
If Cells(Zeile - 1, 2)  Cells(Zeile, 2) Then
For i = 1 To 3
Rows(Zeile).Insert Shift:=xlDown
Next i
End If
Next Zeile
'Zeilen ohne Inhalt werden geloescht
Range("A1:A9").SpecialCells(xlCellTypeBlanks).EntireRow.Delete
'Loescht die Zeilen 4 bis 3 wenn A4 und oder A3 leer ist
Dim iRow As Long
For iRow = 4 To 3 Step -1
If IsEmpty(Cells(iRow, 1)) Then
Rows(iRow).Delete
End If
Next
'Titel wird in Zelle A535 kopiert (spaeter s.u. wieder hier her kopiert)
Range("A1").Select
Selection.Cut
'ActiveWindow.ScrollRow = 506
Range("A535").Select
ActiveSheet.Paste
'Ueberschriften werden ueber jeden Block gesetzt und die Summen von jeden Block gebilden
Dim rng As Range
Dim rngRow As Long
Dim First As Long
Dim Last As Long
With ActiveSheet
Last = .Cells(Rows.Count, 1).End(xlUp).Row
Do
First = .Cells(Last, 1).End(xlUp).Row
.Cells(Last + 1, 10).FormulaLocal = "=Summe(J" & First & ":J" & Last & ")"
.Cells(Last + 1, 11).FormulaLocal = "=Summe(K" & First & ":K" & Last & ")"
.Cells(Last + 1, 12).FormulaLocal = "=Summe(L" & First & ":L" & Last & ")"
.Cells(Last + 1, 13).FormulaLocal = "=Summe(M" & First & ":M" & Last & ")"
.Cells(Last + 1, 14).FormulaLocal = "=Summe(N" & First & ":N" & Last & ")"
.Cells(Last + 1, 15).FormulaLocal = "=Summe(O" & First & ":O" & Last & ")"
If First = 2 Then Exit Do
'Gesamtüberschrift je Spalte werden kopiert
.Range(.Cells(First - 1, 1), .Cells(First - 1, 46)).Value = .Range("A2:AT2").Value
Last = First - 4
'Gesamtueberschriften je Block werden gesetzt
.Range(.Cells(First - 2, 1), .Cells(First - 2, 1)).FormulaR1C1 = .Range("AJ1"). _
FormulaR1C1
Loop
End With
'Titel wird wieder in A1 eingefuegt
Selection.Cut
ActiveWindow.ScrollRow = 3
Range("A1").Select
ActiveSheet.Paste
'Zwei leere Zeilen werden in Zeile 2 eingefuegt und darueber die Block Ueberschrift gesetzt
Rows("2:2").Select
Selection.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
Selection.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
ActiveWindow.SmallScroll ToRight:=38
Range("AJ1").Select
Selection.Copy
Range("A3").Select
ActiveSheet.Paste
' Spalte A wird linksbuendig und fettdruck
Columns("A:A").Select
With Selection
.HorizontalAlignment = xlLeft
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.MergeCells = False
End With
Selection.Font.Bold = True
'Ueberschriften werden je Block rot Markiert
Dim rngU As Range
Dim rngB As Range
Set rngU = ActiveSheet.UsedRange
With rngU
Set rngB = rngU.Find("HR-EDEKA*", SearchDirection:=xlNext)
If Not rngB Is Nothing Then
firstAddress = rngB.Address
Do
pos1 = InStr(rngB.Cells.Value, "HR-EDEKA*") 'die Position des ersten Buchstaben
pos2 = 80 'die Zeichenlänge
rngB.Cells.Characters(pos1, pos2).Font.ColorIndex = 18 'hier weist man die Farbe den  _
Zeichen zu
Set rngB = .FindNext(rngB) 'und das nächste wird gesucht
Loop While Not rngB Is Nothing And rngB.Address  firstAddress
End If
End With
Set rngB = Nothing
Set rngU = Nothing
'Zweite Ueberschriften werden gruen hinterlegt
Dim rngFind As Range
With Worksheets("Auflagenliste").Range("A:A")
Set rngFind = .Find("Handzettel*", LookIn:=xlValues, LookAt:=xlWhole)
If Not rngFind Is Nothing Then
firstAddress = rngFind.Address
Do
Rows(rngFind.Row).Interior.ColorIndex = 4
Set rngFind = .FindNext(rngFind)
Loop While rngFind.Address  firstAddress
End If
End With
'GV_W/O_EDEKA Finden und durch GV_W/O ersetzten
Application.CutCopyMode = False
Cells.Replace What:="GV_W/O_EDEKA", Replacement:="GV_W/O", LookAt:= _
xlWhole, SearchOrder:=xlByRows, MatchCase:=False
Range("E4").Select
'Dokument wird unter "speichern unter" gespeichert
Dim Dateiname As String
Dateiname = Range("A1") & " " & "Inline/Strube.xlsx"
Application.Dialogs(xlDialogSaveAs).Show Dateiname
End Sub
Die Tabelle ist folgendermassen aufgebaut:
Spalte A:AW Zeile 1:358 (kann aber auch mehr werden) sind mit Daten befüllt.
Hier sind verschiedene Werte untergebracht. Jetzt soll die Tabelle nach spalte B und danach nach spalte A sortiert werden und dann jeweilige Blocke daraus erstellt werden. Also die Werte die in Spalte B und dann A gleich sind bilden jeweils ein Block (es werden um die Block abzugrenzen, jeweils 3 Zeilen dazwischen erstellt). Über jeden Block sollen die entsprechenden Überschriften und darunter die Summen gebildet werden.
Ich hoffe es ist verstandlich.
Mein Problem ist nur, dass beim letzten Block in der vorletzten Zeile des Blockes immer die Überschriften einfach eingetragen werden, obwohl hier ein Wert drin steht. Er soll ja die Überschriften, wie bei den Blocken davor darüber schreiben und nicht in den Block. Ich verstehe leider nicht warum.
Danke
Anzeige
AW: Bitte den vollständigen Code für die genannte
24.07.2018 14:32:39
Jan
Hallo Daniel,
so sieht der Code aus:
Dim rng As Range
Dim rngRow As Long
Dim First As Long
Dim Last As Long
With ActiveSheet
Last = .Cells(Rows.Count, 1).End(xlUp).Row
Do
.Cells(Last + 1, 10).Resize(1, 6).FormulaLocal = "=Summe(J" & First & ":J" & Last & ")"
First = .Cells(Last, 1).End(xlUp).Row
.Cells(Last + 1, 10).FormulaLocal = "=Summe(J" & First & ":J" & Last & ")"
.Cells(Last + 1, 11).FormulaLocal = "=Summe(K" & First & ":K" & Last & ")"
.Cells(Last + 1, 12).FormulaLocal = "=Summe(L" & First & ":L" & Last & ")"
.Cells(Last + 1, 13).FormulaLocal = "=Summe(M" & First & ":M" & Last & ")"
.Cells(Last + 1, 14).FormulaLocal = "=Summe(N" & First & ":N" & Last & ")"
.Cells(Last + 1, 15).FormulaLocal = "=Summe(O" & First & ":O" & Last & ")"
If First = 2 Then Exit Do
.Range(.Cells(First - 1, 1), .Cells(First - 1, 46)).Value = .Range("A2:AT2").Value
Last = First - 4
.Range(.Cells(First - 2, 1), .Cells(First - 2, 1)).FormulaR1C1 = .Range("AZ1"). _
FormulaR1C1
Loop
End With

Kannst Du mir hier evtl. noch mal helfen.
Danke
Anzeige
AW: Bitte den vollständigen Code für die genannte
20.07.2018 07:27:52
Jan
Hallo,
hat noch einer einen Tipp für mich?
Danke
AW: Bitte den vollständigen Code für die genannte
24.07.2018 07:57:10
Jan
Hallo,
kann mir hier keiner Helfen?
Danke

Beliebteste Forumthreads (12 Monate)

Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige