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