AW: Adressen
30.03.2005 17:30:23
Frank
Hallo Ben,
hier eine Variante, die mit den geposteten Daten funktioniert:
Sub Ben()
Dim lngRowWS1 As Long
Dim lngRowWS2 As Long
Dim ws1 As Worksheet
Dim ws2 As Worksheet
Dim strPLZ As String
Dim strOrt As String
Dim strFirma1 As String
Dim strFirma2 As String
Dim strTel As String
Dim strWWW As String
Dim strEmail As String
Set ws1 = ActiveSheet
Set ws2 = Worksheets.Add(After:=ws1)
ws2.Name = "Adressen Neu"
ws1.Select
lngRowWS1 = 1
lngRowWS2 = 1
For lngRowWS1 = 1 To ws1.UsedRange.SpecialCells(xlCellTypeLastCell).Row
If Len(Range("B" & lngRowWS1) & "") = 0 Then
' Leerzeile
ElseIf Left(Range("B" & lngRowWS1), 2) = "D-" Then
' Neuer Eintrag, vorhandene Daten übertragen
If Len(strPLZ) = 0 Then
' Beim ersten Mal gibt es noch keine Daten!
Else
ws2.Cells(lngRowWS2, "A") = strPLZ
ws2.Cells(lngRowWS2, "B") = strOrt
ws2.Cells(lngRowWS2, "C") = strFirma1
ws2.Cells(lngRowWS2, "D") = strFirma2
ws2.Cells(lngRowWS2, "E") = strTel
ws2.Cells(lngRowWS2, "F") = strWWW
ws2.Cells(lngRowWS2, "G") = strEmail
lngRowWS2 = lngRowWS2 + 1
strOrt = ""
strFirma1 = ""
strFirma2 = ""
strTel = ""
strWWW = ""
strEmail = ""
End If
strPLZ = Range("B" & lngRowWS1)
ElseIf Len(strPLZ) > 0 And Len(strOrt) = 0 Then
strOrt = Range("B" & lngRowWS1)
ElseIf Len(strFirma1) = 0 Then
strFirma1 = Range("B" & lngRowWS1)
ElseIf Len(strFirma2) = 0 And Not IsNumeric(Trim(Left(Range("B" & lngRowWS1), 1))) Then
strFirma2 = Range("B" & lngRowWS1)
ElseIf IsNumeric(Trim(Left(Range("B" & lngRowWS1), 1))) Then
strTel = Range("B" & lngRowWS1)
ElseIf InStr(1, Range("B" & lngRowWS1), "@") = 0 Then
strEmail = Range("B" & lngRowWS1)
Else
strWWW = Range("B" & lngRowWS1)
End If
Next
End Sub
Viel Spaß
Frank.