Datensortier-Markro: Excel hängt sich weg
23.03.2005 16:01:48
tom
da ist folgendes Szenario: In Spalte A habe ich Adress-Daten importiert.
Dort lasse ich per Makro z.B. nach "Name" suchen. Dann wird per Makro
3 Zellen weiter nach unten gehüpft, weil da immer der zugehörige Eintrag steht.
Soweit sogut.
Ich habe mir vermutlich ein grausiges Makro gebastelt.
Excel denkt das auch und nimmt sich den Strick - hängt sich also auf :-)
Meine Fragen also:
Geht es einfacher? Wenn nein: Warum hängt sich das Teil weg?
Vielen Dank für Eure Zeit!
Viele Grüße, tom
Sub Nokiadaten_sortieren()
Range("A1").Select
Dim gefunden As Range
' Beginn sortieren
Name1:
Range("A1").Select
'In Spalte A nach vollständigem Begriff "Name" suchen:
Set gefunden = Range("A:A").Find(what:="Name", lookat:=xlWhole)
'Wenn "Name" gefunden wurd gehe zu Sprungmarke "Name2"
If Not gefunden Is Nothing Then
GoTo Name2
'Wenn nicht "Name" gefunden wurde gehe zu Sprungmarke "Company1"
Else
GoTo Company1
End If
Name2:
Range("A1").Select
Set gefunden = Range("A:A").Find(what:="Name", lookat:=xlWhole)
If Not gefunden Is Nothing Then gefunden.Select
ActiveCell.ClearContents
' 3 Zellen nach unten springen:
ActiveCell.Offset(3, 0).Select
Selection.Copy
' In nächste freie Zelle der Spalte D springen:
Sheets("Kundeneingabe").Cells(Rows.Count, 4).End(xlUp)(2, 1).Select
ActiveSheet.Paste
Application.CutCopyMode = False
GoTo Name1
Company1:
Range("A1").Select
Set gefunden = Range("A:A").Find(what:="Company", lookat:=xlWhole)
If Not gefunden Is Nothing Then
GoTo Company2
Else
GoTo JobTitle1
End If
Company2:
Range("A1").Select
Set gefunden = Range("A:A").Find(what:="Company", lookat:=xlWhole)
If Not gefunden Is Nothing Then gefunden.Select
ActiveCell.ClearContents
ActiveCell.Offset(3, 0).Select
Selection.Copy
Sheets("Kundeneingabe").Cells(Rows.Count, 3).End(xlUp)(2, 1).Select
ActiveSheet.Paste
Application.CutCopyMode = False
GoTo Company1
JobTitle1:
Range("A1").Select
Set gefunden = Range("A:A").Find(what:="Job", lookat:=xlPart)
If Not gefunden Is Nothing Then
GoTo JobTitle2
Else
GoTo Adress1a
End If
JobTitle2:
Range("A1").Select
Set gefunden = Range("A:A").Find(what:="Job", lookat:=xlPart)
If Not gefunden Is Nothing Then gefunden.Select
ActiveCell.ClearContents
ActiveCell.Offset(3, 0).Select
Selection.Copy
Sheets("Kundeneingabe").Cells(Rows.Count, 5).End(xlUp)(2, 1).Select
ActiveSheet.Paste
Application.CutCopyMode = False
GoTo JobTitle1
Adress1a:
' Adress1a für Straße und Adresss1b für Ort
Range("A1").Select
Set gefunden = Range("A:A").Find(what:="Address", lookat:=xlWhole)
If Not gefunden Is Nothing Then
GoTo Adress2a
Else
GoTo Adress1b
End If
Adress2a:
Range("A1").Select
Set gefunden = Range("A:A").Find(what:="Address", lookat:=xlWhole)
If Not gefunden Is Nothing Then gefunden.Select
ActiveCell.Offset(3, 0).Select
Selection.Copy
Sheets("Kundeneingabe").Cells(Rows.Count, 6).End(xlUp)(2, 1).Select
ActiveSheet.Paste
Application.CutCopyMode = False
GoTo Adress1a
Adress1b:
Range("A1").Select
Set gefunden = Range("A:A").Find(what:="Address", lookat:=xlWhole)
If Not gefunden Is Nothing Then
GoTo Adress2b
Else
GoTo Tel1
End If
Adress2b:
Range("A1").Select
Set gefunden = Range("A:A").Find(what:="Address", lookat:=xlWhole)
If Not gefunden Is Nothing Then gefunden.Select
ActiveCell.ClearContents
ActiveCell.Offset(4, 0).Select
Selection.Copy
Sheets("Kundeneingabe").Cells(Rows.Count, 7).End(xlUp)(2, 1).Select
ActiveSheet.Paste
Application.CutCopyMode = False
GoTo Adress1b
Tel1:
Range("A2").Select
Call ScreenAn
End Sub