Tabellenblatt nach Vorgaben formatieren?

Hallo Leute,
ich muss eine Tabelle leider jeden Tag in vielen Dateien formatieren.
1. Ab START-Zeile "KGR" + 1 bis letzte benutzte Zelle der Spalte A, sollen die Inhalte in Spalten A und B bis nächstem Zellwert gelöscht werden, der anders ist als der vorheriger Zellwert.
2. Ab START-Zeile "KGR" + 1 bis letzte benutzte Zelle der Spalte A, sollen die Inhalte in Spalten C ähnlich wie im Punkt 1 gelöscht werden. Wobei in diesem Fall eine Zeile übersprungen werden soll, sofern in Spalte B ein Zellinhalt steht.
3. Es soll ein roter Rahmen (außen), um die Zellen zwischen einzelnen KGR (Kostengruppen) der Spalte A dargestellt werden.
4. Ab START-Zeile "KGR" + 1 bis letzte benutzte Zelle der Spalte A, sollen die Rahmen für Spalten A, B und C wie im Arbeitsblatt "NACHHER" entfallen.
Leider ist mein Anliegen vielleicht schwer zu erklären, von daher habe ich eine Beispieldatei https://www.herber.de/bbs/user/146021.xlsx mit wenigen Zeilen hier beigefügt.
In der Datei habe ich zwei Arbeitsblättern "VORHER" und "NACHHER" zum besserem Verständnis erstellt.
Ich hoffe ihr könnt mir bitte behilflich sein, dies per VBA zu lösen.
Herrlichen Dank im Voraus!
Gruß Dino

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Zeilenzahl = ActiveSheet.Cells(Rows.Count, 6).End(xlUp).Row 'Ermittlung der letzten genutzten Zeile, 6=F For i = 7 To Zeilenzahl 'Schleife von 7. Zeile bis zur letzten genutzten If Range("A" & i).Value = "410" Then 'wenn '410' in einer Zelle der Spalte A steht, Range("A" & i, "C" & i).Interior.Color = RGB(196, 215, 155) 'dann in der Zeile in Spalten A:C Hintergrundfarbe End If Next i

Sub Layout_anpassen() Dim Startzeile As Long Dim i As Long Dim z As Long Dim lz As Long Dim cl As Long Dim startwert As String Startzeile = 7 lz = ActiveSheet.Cells(Rows.Count, "A").End(xlUp).Row For i = Startzeile To lz startwert = Cells(i, "C") & Cells(i, "A") For z = i + 1 To lz + 1 If Cells(z, "C") & Cells(z, "A") startwert Then If i + 1 startwert Then If i + 1

Moin
Hatte nur mitgelesen. Hier mein Loesungsvorschlag. Probier mal.


Sub Versuch()
Dim rngLast As Range, rngFirst As Range, zelle As Range
Dim i As Long
Application.ScreenUpdating = False
For i = 7 To Cells(Rows.Count, 1).End(xlUp).Row
Set rngLast = Range("A:A").Find(what:=Cells(i, 1), after:=Range("A1"), searchdirection:=xlPrevious)
Set rngFirst = Range("A:A").Find(what:=Cells(i, 1), after:=Range(rngLast.Address), searchdirection:=xlNext)
With Range(rngFirst, rngLast)
.Cells(1).Resize(rngLast.Row - rngFirst.Row + 1, 8).BorderAround 1, 3, 22
.Cells(2).Resize(rngLast.Row - rngFirst.Row, 2).ClearContents
Select Case .Cells(1)
Case 410: .Cells(1).Resize(rngLast.Row - rngFirst.Row + 1, 2).Interior.Color = RGB(196, 215, 155)
Case 420: .Cells(1).Resize(rngLast.Row - rngFirst.Row + 1, 2).Interior.Color = RGB(141, 180, 226)
Case 430: .Cells(1).Resize(rngLast.Row - rngFirst.Row + 1, 2).Interior.Color = RGB(230, 184, 183)
Case 440: .Cells(1).Resize(rngLast.Row - rngFirst.Row + 1, 2).Interior.Color = RGB(183, 222, 232)
Case 475: .Cells(1).Resize(rngLast.Row - rngFirst.Row + 1, 2).Interior.Color = RGB(221, 217, 196)
End Select
For Each zelle In .Offset(, 2)
If Application.CountIf(Range(zelle, Cells(rngLast.Row, 3)), zelle) > 1 Then
Range(zelle.Offset(1, 0), Cells(rngLast.Row, 3)).Replace what:=zelle, replacement:=""
End If
Next
End With
i = rngLast.Row + 1
Set rngLast = Nothing
Set rngFirst = Nothing
Next
End Sub

gruss hary

Beliebteste Forumthreads (12 Monate)

Tabellenblatt nach Vorgaben formatieren?

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

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

10
Beiträge zum Forumthread

Beiträge zu diesem Forumthread