AW: neues blatt mit namen aus spalte erstellen
22.09.2004 12:21:07
chris
Hallo Stephan habe schnell mal was geschrieben für dich !
Hoffe es hilft dir.Bei mir funktioniert es!
Hier der Code
Sub neu()
Dim cb()
i = 0
z = 0
For x = 1 To ActiveSheet.Cells(Rows.Count, 1).End(xlUp).Row
temp = Cells(x, 1)
b = True
If temp <> "" Then
ReDim Preserve cb(z)
z = z + 1
Else
End If
For y = x - 1 To 0 Step -1
If cb(y) = temp Then
b = False
Exit For
End If
Next
If b Then
cb(i) = temp
i = i + 1
End If
Next
For x = 0 To UBound(cb)
If cb(x) <> "" Then
Worksheets.Add
ActiveSheet.Name = cb(x)
Cells(1, 1) = "Betreuer"
Cells(1, 2) = "Kunde"
Cells(1, 3) = "Artikel"
End If
Next
For Each mysheet In ActiveWorkbook.Worksheets
a = 2
such = mysheet.Name
Set Zelle = Worksheets("Tabelle1").Range("A:A").Find(what:=such, Lookat:=xlWhole)
If Not Zelle Is Nothing Then
ersteAdresse = Zelle.Address
betreuer = Worksheets("Tabelle1").Cells(Zelle.Row, 1)
wert = Worksheets("Tabelle1").Cells(Zelle.Row, 2)
artikel = Worksheets("Tabelle1").Cells(Zelle.Row, 3)
Worksheets(such).Cells(a, 1) = betreuer
Worksheets(such).Cells(a, 2) = wert
Worksheets(such).Cells(a, 3) = artikel
a = a + 1
Do
' Zelle.Interior.Pattern = xlPatternGray50 <-- würde die find zelle grau Färben hintergrund !
Set Zelle = Worksheets("Tabelle1").Range("A:A").FindNext(Zelle)
betreuer = Worksheets("Tabelle1").Cells(Zelle.Row, 1)
wert = Worksheets("Tabelle1").Cells(Zelle.Row, 2)
artikel = Worksheets("Tabelle1").Cells(Zelle.Row, 3)
Worksheets(such).Cells(a, 1) = betreuer
Worksheets(such).Cells(a, 2) = wert
Worksheets(such).Cells(a, 3) = artikel
a = a + 1
Loop While Not Zelle Is Nothing And Zelle.Address <> ersteAdresse
End If
Next
End Sub