hier die manuelle Lösung:
Formel für SpalteA: =RECHTS(opsur!A2)
Formel für SpalteB: =TEIL(opsur!B2)
Beide Formeln nach unten kopieren.
Im Blatt Filter:
>Daten>Filter>Autofilter
auf den Dropdown neben einem der Spaltenköpfe klicken und "Nichtleere" auswählen.
Steffan.
und hier die automatische Lösung:
'Vereinbarungen 'alten Filter löschen 'Kopf kopieren 'Daten übertragen End Sub
Code eingefügt mit Syntaxhighlighter 1.16
Private Sub übertrag()
Dim oSheet1 As Worksheet
Dim oSheet2 As Worksheet
Set oSheet1 = Worksheets("opsur")
Set oSheet2 = Worksheets("filter")
oSheet2.Cells(1, 1).CurrentRegion.ClearContents
oSheet2.Cells(1, 1).Value = oSheet1.Cells(1, 1).Value
oSheet2.Cells(1, 2).Value = oSheet1.Cells(1, 2).Value
For j = 1 To 2
For i = 2 To oSheet1.Cells(65536, j).End(xlUp).Row
If Not (oSheet1.Cells(i, j).Value = Empty) Then
On Error Resume Next
If j = 1 Then
oSheet2.Cells(oSheet2.Cells(65536, j). _
End(xlUp).Row + 1, j).Value = _
Format(Right(oSheet1.Cells(i, j).Value, 4), "0000")
Else
oSheet2.Cells(oSheet2.Cells(65536, j). _
End(xlUp).Row + 1, j).Value = _
Format(Mid(oSheet1.Cells(i, j).Value, 2, 4), "0000")
End If
End If
Next i
Next j
PS:
Nur der Vollständigkeit halber:
Die Formeln in meinem 1. Beitrag haben so nicht gestimmt, richtig ist:
Formel für SpalteA: =RECHTS(opsur!A2;4)
Formel für SpalteB: =TEIL(opsur!B2;2;4)
ich hatte gedacht, die Zellen in Deinem Quellblatt sind ganz leer und nicht mit "/ " oder "abc" gefüllt, aber Deine Datei hat es ja aufgeklärt. Hier der ergänzte Code:
'Vereinbarungen 'alten Filter löschen 'Kopf kopieren 'Daten übertragen End Sub
Private Sub übertrag()
Dim oSheet1 As Worksheet
Dim oSheet2 As Worksheet
Set oSheet1 = Worksheets("OPSUR")
Set oSheet2 = Worksheets("Filter")
oSheet2.Cells(1, 1).CurrentRegion.ClearContents
oSheet2.Cells(1, 1).Value = oSheet1.Cells(1, 1).Value
oSheet2.Cells(1, 2).Value = oSheet1.Cells(1, 2).Value
For j = 1 To 2
For i = 2 To oSheet1.Cells(65536, j).End(xlUp).Row
If j = 1 Then
If Len(Trim(oSheet1.Cells(i, j).Value)) > 3 Then _
oSheet2.Cells(oSheet2.Cells(65536, j). _
End(xlUp).Row + 1, j).Value = _
Format(Mid(oSheet1.Cells(i, j).Value, 4, 4), "0000")
Else
If Len(Trim(oSheet1.Cells(i, j).Value)) > 1 Then _
oSheet2.Cells(oSheet2.Cells(65536, j). _
End(xlUp).Row + 1, j).Value = _
Format(Mid(oSheet1.Cells(i, j).Value, 2, 4), "0000")
End If
Next i
Next j