Cheffe kann kommen
19.11.2009 12:01:52
NoNet
Hallo Daniel,
Dein Chef kann gerne kommen, nachdem Du folgendes Makro ausgeführt hast :
Sub KlinikenSortieren()
Dim lngS As Long, lngZ As Long, lngZ1 As Long
Dim wsAkt As Worksheet, wsSortiert As Worksheet
Set wsAkt = ActiveSheet
Set wsSortiert = Worksheets.Add
wsSortiert.Name = "Klinken sortiert"
wsSortiert.[A1:G1] = Array("Name", "Strasse", "PLZ", "Telefon", "Fax", "eMail", "Internet")
lngZ1 = 1
With wsAkt
For lngZ = 1 To .Cells(Rows.Count, 1).End(xlUp).Row
If Not IsEmpty(.Cells(lngZ, 1)) Then
If .Cells(lngZ, 1).Font.Size = 18 Then
lngS = 1
lngZ1 = lngZ1 + 1
ElseIf IsNumeric(Left(.Cells(lngZ, 1), 5)) Then
lngS = 3
ElseIf Left(.Cells(lngZ, 1), 4) = "Tel." Then
lngS = 4
ElseIf Left(.Cells(lngZ, 1), 4) = "Fax." Then
lngS = 5
ElseIf InStr(.Cells(lngZ, 1), "@") > 0 Then
lngS = 6
ElseIf .Cells(lngZ, 1).Hyperlinks.Count > 0 Then
lngS = 1
lngZ1 = lngZ1 + 1 'Neue Klinik
Else
lngS = 2
End If
If IsEmpty(wsSortiert.Cells(lngZ1, lngS)) Then
wsSortiert.Cells(lngZ1, lngS) = .Cells(lngZ, 1)
Else
lngZ1 = lngZ1 + 1 'Neue Adresse zur gleichen Klinik
wsSortiert.Cells(lngZ1, lngS) = .Cells(lngZ, 1)
End If
If .Cells(lngZ, 1).Hyperlinks.Count > 0 Then
wsSortiert.Cells(lngZ1, 7) = .Cells(lngZ, 1).Hyperlinks(1).Address
End If
End If
Next
End With
wsSortiert.Columns.AutoFit
End Sub
Ergebnis :
Gruß, NoNet