Makro vereinfachen
11.10.2004 09:52:47
Hanno
ich habe unten angehängte Makros geschrieben. Sie unterscheiden sich nur in einzelnen Variablen.
Nun meine Frage: Kann man diese Makros nicht zusammenfassen, so dass ich nur ein Makro ausführen muss? Ich kenne mich da leider nicht so gut aus.
Vielen Dank im Voraus,
Hanno
Sub NachMontagenSortieren()
Dim rng As Range
Dim lngE As Long 'für letzte gefüllte Zeile
Dim lngRow As Long 'Zeilenzähler in "OH"
lngRow = 1
'Letzte gefüllte Zelle in Spalte "C" ermitteln
lngE = IIf(IsEmpty(Sheets("Data2").Range("C65536")), Sheets("Data2").Range("C65536").End(xlUp).Row, 65536)
Sheets("Mo").Columns("a").ClearContents
Sheets("Mo").Columns("b").ClearContents
Sheets("Mo").Columns("c").ClearContents
Sheets("Mo").Columns("d").ClearContents
For Each rng In Sheets("Data2").Range("A1:A" & lngE)
If rng <> "" And rng = 2 Then
Sheets("Mo").Cells(lngRow, 1) = rng.Offset(0, 1)
Sheets("Mo").Cells(lngRow, 2) = rng.Offset(0, 2)
Sheets("Mo").Cells(lngRow, 3) = rng.Offset(0, 3)
Sheets("Mo").Cells(lngRow, 4) = rng.Offset(0, 4)
'Zeilenzähler erhöhen
lngRow = lngRow + 1
End If
Next
End Sub
Sub NachDienstagenSortieren()
Dim rng As Range
Dim lngE As Long 'für letzte gefüllte Zeile
Dim lngRow As Long 'Zeilenzähler in "OH"
lngRow = 1
'Letzte gefüllte Zelle in Spalte "C" ermitteln
lngE = IIf(IsEmpty(Sheets("Data2").Range("C65536")), Sheets("Data2").Range("C65536").End(xlUp).Row, 65536)
Sheets("Di").Columns("a").ClearContents
Sheets("Di").Columns("b").ClearContents
Sheets("Di").Columns("c").ClearContents
Sheets("Di").Columns("d").ClearContents
For Each rng In Sheets("Data2").Range("A1:A" & lngE)
If rng <> "" And rng = 3 Then
Sheets("Di").Cells(lngRow, 1) = rng.Offset(0, 1)
Sheets("Di").Cells(lngRow, 2) = rng.Offset(0, 2)
Sheets("Di").Cells(lngRow, 3) = rng.Offset(0, 3)
Sheets("Di").Cells(lngRow, 4) = rng.Offset(0, 4)
'Zeilenzähler erhöhen
lngRow = lngRow + 1
End If
Next
End Sub
Sub NachMittwochenSortieren()
Dim rng As Range
Dim lngE As Long 'für letzte gefüllte Zeile
Dim lngRow As Long 'Zeilenzähler in "OH"
lngRow = 1
'Letzte gefüllte Zelle in Spalte "C" ermitteln
lngE = IIf(IsEmpty(Sheets("Data2").Range("C65536")), Sheets("Data2").Range("C65536").End(xlUp).Row, 65536)
Sheets("Mi").Columns("a").ClearContents
Sheets("Mi").Columns("b").ClearContents
Sheets("Mi").Columns("c").ClearContents
Sheets("Mi").Columns("d").ClearContents
For Each rng In Sheets("Data2").Range("A1:A" & lngE)
If rng <> "" And rng = 4 Then
Sheets("Mi").Cells(lngRow, 1) = rng.Offset(0, 1)
Sheets("Mi").Cells(lngRow, 2) = rng.Offset(0, 2)
Sheets("Mi").Cells(lngRow, 3) = rng.Offset(0, 3)
Sheets("Mi").Cells(lngRow, 4) = rng.Offset(0, 4)
'Zeilenzähler erhöhen
lngRow = lngRow + 1
End If
Next
End Sub
Sub NachDonnerstagenSortieren()
Dim rng As Range
Dim lngE As Long 'für letzte gefüllte Zeile
Dim lngRow As Long 'Zeilenzähler in "OH"
lngRow = 1
'Letzte gefüllte Zelle in Spalte "C" ermitteln
lngE = IIf(IsEmpty(Sheets("Data2").Range("C65536")), Sheets("Data2").Range("C65536").End(xlUp).Row, 65536)
Sheets("Do").Columns("a").ClearContents
Sheets("Do").Columns("b").ClearContents
Sheets("Do").Columns("c").ClearContents
Sheets("Do").Columns("d").ClearContents
For Each rng In Sheets("Data2").Range("A1:A" & lngE)
If rng <> "" And rng = 5 Then
Sheets("Do").Cells(lngRow, 1) = rng.Offset(0, 1)
Sheets("Do").Cells(lngRow, 2) = rng.Offset(0, 2)
Sheets("Do").Cells(lngRow, 3) = rng.Offset(0, 3)
Sheets("Do").Cells(lngRow, 4) = rng.Offset(0, 4)
'Zeilenzähler erhöhen
lngRow = lngRow + 1
End If
Next
End Sub
Sub NachFreitagenSortieren()
Dim rng As Range
Dim lngE As Long 'für letzte gefüllte Zeile
Dim lngRow As Long 'Zeilenzähler in "OH"
lngRow = 1
'Letzte gefüllte Zelle in Spalte "C" ermitteln
lngE = IIf(IsEmpty(Sheets("Data2").Range("C65536")), Sheets("Data2").Range("C65536").End(xlUp).Row, 65536)
Sheets("Fr").Columns("a").ClearContents
Sheets("Fr").Columns("b").ClearContents
Sheets("Fr").Columns("c").ClearContents
Sheets("Fr").Columns("d").ClearContents
For Each rng In Sheets("Data2").Range("A1:A" & lngE)
If rng <> "" And rng = 6 Then
Sheets("Fr").Cells(lngRow, 1) = rng.Offset(0, 1)
Sheets("Fr").Cells(lngRow, 2) = rng.Offset(0, 2)
Sheets("Fr").Cells(lngRow, 3) = rng.Offset(0, 3)
Sheets("Fr").Cells(lngRow, 4) = rng.Offset(0, 4)
'Zeilenzähler erhöhen
lngRow = lngRow + 1
End If
Next
End Sub
Sub NachFreitagenSortieren()
Dim rng As Range
Dim lngE As Long 'für letzte gefüllte Zeile
Dim lngRow As Long 'Zeilenzähler in "OH"
lngRow = 1
'Letzte gefüllte Zelle in Spalte "C" ermitteln
lngE = IIf(IsEmpty(Sheets("Data2").Range("C65536")), Sheets("Data2").Range("C65536").End(xlUp).Row, 65536)
Sheets("Fr").Columns("a").ClearContents
Sheets("Fr").Columns("b").ClearContents
Sheets("Fr").Columns("c").ClearContents
Sheets("Fr").Columns("d").ClearContents
For Each rng In Sheets("Data2").Range("A1:A" & lngE)
If rng <> "" And rng = 6 Then
Sheets("Fr").Cells(lngRow, 1) = rng.Offset(0, 1)
Sheets("Fr").Cells(lngRow, 2) = rng.Offset(0, 2)
Sheets("Fr").Cells(lngRow, 3) = rng.Offset(0, 3)
Sheets("Fr").Cells(lngRow, 4) = rng.Offset(0, 4)
'Zeilenzähler erhöhen
lngRow = lngRow + 1
End If
Next
End Sub