AW: Franz (fcs) - bitte um Hilfe!
10.10.2011 21:36:12
fcs
Hallo Markus,
das Ende der Texte wird vor dem Eintragen in Spalte A geprüft und der Text nicht eingetragen. Das ist in der Summe einfacher abzuarbeiten.
Gruß
Franz
Sub SpalteN_nach_A()
Dim wks As Worksheet
Dim Zeile_N As Long, Zeile_A As Long, StatusCalc As Long
Dim vZelle_N, iIndex As Long, sText As String
With Application
.ScreenUpdating = False
StatusCalc = .Calculation
If StatusCalc xlCalculationManual Then .Calculation = xlCalculationManual
.EnableEvents = False
End With
Set wks = ActiveSheet
With wks
Zeile_A = 12
For Zeile_N = 12 To .Cells(.Rows.Count, 14).End(xlUp).Row
vZelle_N = Split(.Cells(Zeile_N, 14), ";")
If UBound(vZelle_N) = -1 Then 'Zelle in Spalte N ist leer
.Cells(Zeile_A, 1).ClearContents
Zeile_A = Zeile_A + 1
If Zeile_A > .Rows.Count Then
MsgBox "Alle Zeilen der Tabelle sind mit Daten gefüllt!"
GoTo Beenden
End If
Else
For iIndex = LBound(vZelle_N) To UBound(vZelle_N)
sText = Trim(vZelle_N(iIndex))
GoTo Variante_2 'für Variante 1 diese Zeile zu Kommentar machen
Variante_1:
'Ende des Textes prüfen (Variante 1)
If Len(sText) > 0 Then
Select Case Right(sText, 1)
Case "0" To "9", "A", "V", "Z"
.Cells(Zeile_A, 1).Value = sText
Zeile_A = Zeile_A + 1
Case Else
'do nothing, Wert nicht eintragen
End Select
End If
GoTo Weiter03
Variante_2:
'Ende des Textes prüfen (Variante 2)
If Len(sText) > 0 Then
Select Case Right(sText, 1)
Case "0" To "9", "A", "V", "Z"
.Cells(Zeile_A, 1).Value = sText
Zeile_A = Zeile_A + 1
Case Else
Do
'letztes Zeichen + evtl. Leerzeichen abtrennen
sText = Trim(Left(sText, Len(sText) - 1))
If Len(sText) = 0 Then Exit Do
If IsNumeric(Right(sText, 1)) Then Exit Do 'nur unzulässige Buchstaben
Select Case Right(sText, 1)
Case "A", "V", "Z"
.Cells(Zeile_A, 1).Value = sText
Zeile_A = Zeile_A + 1
Exit Do
Case Else
'do nothing - Schleife wiederholen
End Select
Loop
'do nothing, Wert nicht eintragen
End Select
End If
Weiter03:
If Zeile_A > .Rows.Count Then
MsgBox "Alle Zeilen der Tabelle sind mit Daten gefüllt!"
GoTo Beenden
End If
Next
End If
Next
End With
Beenden:
With Application
.ScreenUpdating = True
.Calculation = StatusCalc
If StatusCalc .Calculation Then .Calculation = StatusCalc
.EnableEvents = True
End With
End Sub