Hilfe bei VBA Prozedur
22.12.2004 11:01:25
Martin
hab da ein riesiges Problem mit einer Prozedur und hoffe Ihr könnt mir da evtl. weiterhelfen.
Folgende Situation:
Ich habe im Excel eine Datei, in der ca. 5000 Zeilen gefüllt sind. Der Inahlt dieser Zeilen ist bis auf einen Teil nicht verwertbar, da er meist nur technische Daten etc. enthält(Export aus einem anderen System). Den Teil den ich benötige, beschränkt sich auf 4 sich wiederholenden angaben (Anrede, Vorname, Nachname, EMail) in Spalte A bzw. B, die in eine neue Tabelle übertragen werden sollen.
Von der Ausganstabelle werden nur die Inhalte der o.g. 4 Angaben benötigt, also das was in der Spalte neben Anrede usw. steht.
Übertrag in neue Tabelle sollte wie folgt aussehen:
1 A /B /C /D
2 Anrede /Vorname /Nachname /E-Mail
3 Beginn mit erster Werteübergabe
4 ...
Meine Versuche sehen wie folgt aus:
_____________________________________________________________________________
Sub Anschriften_Herausfiltern()
Dim WS As Worksheet
Dim strBlatt As String
Dim strAnrede As String
Dim strVorname As String
Dim strNachname As String
Dim strEMail As String
'Dim lngCount As Long
Dim rngBegin As Range
' alte Blätter löschen
On Error Resume Next
Application.DisplayAlerts = False
For Each WS In ThisWorkbook.Worksheets
If Left(WS.Name, 7) = "Weitere" Then WS.Delete
Next WS
Application.DisplayAlerts = True
On Error GoTo 0
' neues Blatt anlegen
strBlatt = "Weitere Infotmationen"
On Error Resume Next
Set WSneu = ThisWorkbook.Worksheets(strBlatt)
If Err.Number <> 0 Then
Set WSneu = ThisWorkbook.Worksheets.Add
WSneu.Name = strBlatt
WSneu.Range("A1") = "Anrede"
WSneu.Range("B1") = "Vorname"
WSneu.Range("C1") = "Nachname"
WSneu.Range("D1") = "E-Mail"
End If
Set WS = Application.ActiveWorkbook.Worksheets("Gewinnspiel101")
Set rngBegin = WS.Range("A1")
With Application
.ScreenUpdating = False
.Calculation = xlCalculationManual
.EnableEvents = False
End With
' Wertezuweisung
Do Until IsEmpty(rngBegin)
If Cells = "Anrede:" Then
strAnrede = ActiveCell.Offset(0, 1).Value
ElseIf Cells.Right(strVorname, 8) = "Vorname:" Then
strVorname = ActiveCell.Offset(0, 1).Value
ElseIf Cells.Right(strNachname, 9) = "Nachname:" Then
strNachname = ActiveCell.Offset(0, 1).Value
ElseIf Cells.Right(strEMail, 7) = "E-Mail:" Then
strEMail = ActiveCell.Offset(0, 1).Value
End If
' Datenübergabe an Unterprozedur
Daten strAnrede, strVorname, strNachname, strEMail
Set rngBegin = rngBegin.Offset(1, -1)
Loop
With Application
.ScreenUpdating = True
.Calculation = xlCalculationAutomatic
.EnableEvents = True
End With
End Sub
______________________________________________________________________________
'Unterprozedur
Sub Daten(Anrede As String, Vorname As String, Nachname As String, EMail As String)
Dim lngZeile As Long
lngZeile = WSneu.UsedRange.Rows.Count + 1
WSneu.Cells(lngZeile, 1) = Anrede
WSneu.Cells(lngZeile, 2) = Vorname
WSneu.Cells(lngZeile, 3) = Nachname
WSneu.Cells(lngZeile, 4) = EMail
End Sub
______________________________________________________________________________
Sobald ich nun das ganze ausführen will stürzt mit die Anwendung ab(Liegt warscheinlich an der Schleife für die Wertezuweisung)
Frage nun:
Irgendeine Idee oder eine Hilfestellung, wie ich das anders formulieren muss damit es klappt?
Für eure Hilfe wäre ich sehr dankbar.
MfG
Martin