AW: PDF to Excel - Bestimmte Ziffernfolge suchen
18.02.2016 15:15:44
fcs
Hallo Thorsten,
hier ein entsprechendes Suchmakro.
Gruß
Franz
Sub SucheZahlenmuster()
Dim wks As Worksheet
Dim Zeile As Long, Zeile1 As Long
Dim strZelle As String, strText As String
Dim intK As Integer
Dim arrZahlen() As String, intZ As Integer
Dim strLike As String
Set wks = ActiveSheet
strLike = "## #### ####" 'Vergleichsstring # steht für Ziffer
With wks
For Zeile = 1 To .Cells(.Rows.Count, 1).End(xlUp).Row
strZelle = .Cells(Zeile, 1).Text
For intK = 1 To Len(strZelle)
strText = Mid(strZelle, intK)
If Left(strText, Len(strLike)) Like strLike Then
intZ = intZ + 1
ReDim Preserve arrZahlen(1 To intZ)
arrZahlen(intZ) = Left(strText, Len(strLike))
intK = intK + Len(strLike) - 1
End If
Next
Next
End With
If intZ > 0 Then
Application.ScreenUpdating = False
'neues Blatt für Ergebnis anlegen
ActiveWorkbook.Worksheets.Add after:=wks
Set wks = ActiveSheet
With wks
Zeile1 = 2 '1. EInfügezeile für Zahlenfolgen
Zeile = Zeile1 - 1
For intZ = LBound(arrZahlen) To UBound(arrZahlen)
Zeile = Zeile + 1
.Cells(Zeile, 1).Value = arrZahlen(intZ)
Next
If Zeile > Zeile1 Then
'Zahlen sortieren
With .Range(.Cells(Zeile1, 1), .Cells(Zeile, 1))
.Sort key1:=.Range("A1"), order1:=xlAscending, Header:=xlNo
End With
'mehrfach vorkommende Ziffernfolgen löschen
For Zeile = .Cells(.Rows.Count, 1).End(xlUp).Row To Zeile1 + 1 Step -1
If .Cells(Zeile, 1).Text = .Cells(Zeile - 1, 1).Text Then
.Cells(Zeile, 1).EntireRow.Delete
End If
Next
End If
End With
Application.ScreenUpdating = True
Else
MsgBox "Keine Ziffernfolgen im Format """ & strLike & """ gefunden!"
End If
End Sub