Makro anpassen
09.02.2006 09:22:29
petra
habe folgenden Makro:
er stellt Tabellenblätter in abhängigkeit von Zahlenwerten in Spalte A her.
Public
Sub Verteilen()
Application.ScreenUpdating = False
Dim nNumber As Integer, actSh As Worksheet
Dim bComplete As Boolean
bComplete = False
Dim i As Long, nStart, nEnd As Long
nNumber = 0
For i = 3 To 65536
If Sheets(1).Cells(i, 1).Value = "" Then
nEnd = i - 1
Exit For
End If
If nNumber <> Sheets(1).Cells(i, 1).Value Then
If Not bComplete Then
' neues sheet anlegen
nNumber = Sheets(1).Cells(i, 1).Value
nStart = i
Set actSh = Sheets.Add(after:=Worksheets(Worksheets.Count))
' sheet benennen
ActiveSheet.Name = Trim(Str(nNumber))
Sheets(1).Range("a1:t2").Copy
ActiveSheet.Range("a1").Select
' überschrift kopieren
ActiveSheet.Paste
bComplete = True
Else
nEnd = i - 1
' das ende eines blockes wurde erreicht
End If
End If
' das trifft nur dann zu, wenn
' obige if bcomplete schleife einmal komplett durch laufen wurd
If nEnd > nStart Then
' block kopieren
Sheets(1).Range("A" + Trim(Str(nStart)) + ":T" + Trim(Str(nEnd))).Copy
ActiveSheet.Range("a3").Select
ActiveSheet.Paste
nEnd = 0
nStart = 0
bComplete = False
i = i - 1 'wir sind quasi über das ziel hinausgeschossen
End If
Next i
If nEnd > nStart Then
' block kopieren
Sheets(1).Range("A" + Trim(Str(nStart)) + ":T" + Trim(Str(nEnd))).Copy
ActiveSheet.Range("a3").Select
ActiveSheet.Paste
nEnd = 0
nStart = 0
bComplete = False
i = i - 1 'wir sind quasi über das ziel hinausgeschossen
End If
Application.ScreenUpdating = True
End Sub
Dieser Makro funktioniert leider nur, wenn nur ein Tabellenblatt in dem File vorhanden ist. Jetzt sind aber in der Datei, in dem ich den Makro verwenden will, bereits zwei Tabellenblätter.
Kann man den makro irgendwie umschreiben, dass der dann trotzdem funktioniert?
Vielen Dank für eure hilfe
lg
petra