Makro zum Zählen von fettgedruckten Zeilen
14.08.2006 15:04:11
fettgedruckten
Ich hatte hier letzte Woche schon mal eine Frage hineingestellt, aber hatte leider keine Zeit die Aufgabe zu beenden. Hier ist nochmal meine Situation:
Ich habe diesmal eine Datei angehängt unter https://www.herber.de/bbs/user/35780.xls , die zwei Tabellen in der Datei demonstriert: Ich würde gerne die Fettgedruckten Werte der beiden Tabellen in die Übersichtstabelle unter die Überschrift kopieren und diese dann sortieren unter "Arbeitsaufnahme am". Dieses sollte über eine Makro funktionieren.
Könnte mir da jemand nochmal helfen? Vielen Dank an alle schon einmal im vorraus (und auch nochmal an Bertram für die Beiträge der letzten Woche).
Mit freundlichen Grüßen,
Meister Müller
Hier sind nochmal die Beiträge der letzten Woche zur Info:
Moin,
ich würde gerne eine Makro schreiben, die von mehreren Seiten in einer Datei alle fettgedruckten Zeilen auf eine neue Seite kopiert und sie dann nach Datum sortiert.
Wäre das möglich? Und wenn ja, wie?
Danke!
Hallo,
so:
Sub FetteKopierenUndSortieren()
Dim i As Long
Dim j As Long
j = 1
With Sheets(1)
For i = 1 To .Cells(65536, 1).End(xlUp).Row
If .Cells(i, 1).Font.Bold Then
Sheets(2).Cells(j, 1).Value = .Cells(i, 1).Value
j = j + 1
End If
Next i
End With
Sheets(2).Columns("A:A").Sort Key1:=Range("A1"), Order1:=xlAscending, Header:=xlGuess, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
End Sub
Gruß
Bertram
Vielen Dank für Deine Hilfe. Eine Frage noch: Wie mache ich in der Formel deutlich, dass ich eine ganze Reihe rüberkopieren möchte (z.B. A1:A15, B1:B15, etc.)? Und wie kann ich noch weitere Tabellen mit in die Formel einbeziehen?
Vielen Dank nochmal!
Hi,
habe den Code mal abgeändert, dass er immer Spalten 1-15 kopiert und anschließend sortiert.
Sub FetteKopierenUndSortieren()
Dim i As Long
Dim j As Long
j = 1
With Sheets(1)
For i = 1 To .Cells(65536, 1).End(xlUp).Row
If .Cells(i, 1).Font.Bold Then
.Range(Cells(i, 1), Cells(i, 15)).Copy Destination:=Sheets(2).Cells(j, 1)
j = j + 1
End If
Next i
End With
With Sheets(2)
.Activate
.Columns("A:O").Sort Key1:=Range("A1"), Order1:=xlAscending, Header:=xlGuess, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
End With
End Sub
Kannst du genauer beschreiben, was du mit den anderen Tabellen machen willst?
Gruß
Bertram