'Dank an Herber
Sub Sort_Wind()
Dim arr As Variant
Dim iRow As Integer, iArr As Integer, iAdd As Integer, iChr As Integer
Dim sTxt As String
Worksheets("Target").Select
Range("d6:ae80").ClearContents
Range("D6:P80").NumberFormat = "@"
For iRow = 6 To 80 'Spalte AE6 bis AE80
If IsEmpty(Cells(iRow, 33)) Then Exit For 'Wenn Spalte 33, also AG Leer dann For-Schleife verlassen
iAdd = 0
sTxt = Cells(iRow, 33).Value '33 ist Spalte AG, also AG6 dann AG7...
arr = Split(sTxt)
Cells(iRow, 3).Value = Trim$(arr(0)) '3 ist Spalte C wo ICAO kommt
Cells(iRow, 4).Value = Trim$(Format(Clng(Mid(arr(1), 1, 2)), "00")) '4 ist Spalte D wo dd kommt
Cells(iRow, 5).Value = Trim$(Format(Clng(Mid(arr(1), 3, 4)), "0000")) '5 ist Spalte E wo hhhh kommt
Cells(iRow, 6).Value = Trim$(Mid(arr(1), 7, 1)) '6 ist Splate F wo Z kommt
If arr(2) Like "*#*" = False Then 'Wenn 3'te Array AUTO ...
Cells(iRow, 7).Value = Trim$(arr(2)) '7 ist Spalte G wo AUTO kommt
iAdd = iAdd + 1
End If
Cells(iRow, 8).Value = Trim$(Format(Mid(arr(2 + iAdd), 1, 3), "000")) '8 ist Spalte H wo Grad kommt
Cells(iRow, 11).Value = Mid(arr(2 + iAdd), 4, 2) '11 ist Spalte K wo KTzahl kommt
If InStr(arr(2 + iAdd), "G") Then
Cells(iRow, 10).Value = "G" '10 ist Spalte J wo Buchstabe G kommt
Cells(iRow, 9).Value = Trim$(Format(Mid(arr(2 + iAdd), 4, 2), "00")) '9 ist Spalte i wo KTzahl kommt
Cells(iRow, 11).Value = Trim$(Format(Mid(arr(2 + iAdd), 7, 2), "00")) '11 ist spalte K wo KTzahl kommt
Else
Cells(iRow, 11).Value = Trim$(Mid(arr(2 + iAdd), 4, 2))
Cells(iRow, 12).Value = Trim$(Right(arr(2 + iAdd), Len(arr(2 + iAdd)) - 5)) '12 ist Spalte L wo KTbuchstaben kommt
End If
For iChr = Len(arr(2 + iAdd)) To 4 Step -1
If IsNumeric(Mid(arr(2 + iAdd), iChr, 1)) Then Exit For
Next iChr
Cells(iRow, 12).Value = Trim$(Right(arr(2 + iAdd), Len(arr(2 + iAdd)) - iChr))
If arr(3 + iAdd) Like "*#V#*" Then
Cells(iRow, 13).Value = Trim$(Format(Left(arr(3 + iAdd), InStr(arr(3 + iAdd), "V") - 1), "000"))
Cells(iRow, 14).Value = "V"
Cells(iRow, 15).Value = Trim$(Format(Right(arr(3 + iAdd), Len(arr(3 + iAdd)) - InStr(arr(3 + iAdd), "V")), "000"))
Cells(iRow, 16).Value = Trim$(Format(arr(4 + iAdd), "0000"))
ElseIf arr(3 + iAdd) Like "####" Or arr(3 + iAdd) = "CAVOK" Then
Cells(iRow, 16).Value = Trim$(Format(arr(3 + iAdd), "0000"))
End If
'Begin Zusatz von mir
If arr(4) Like "####[SNEW]" Then
Cells(iRow, 17).Value = Trim$(arr(4))
iAdd = iAdd + 1
End If
'Ende Zusatz
Next iRow
End Sub
Sub CrossCheck()
Dim rng As Range 'Variablendeklarationen gehören immer an den Beginn einer Prozedur
'Lösche Bereich
With Range("AD6:AF113") 'man barucht kein .Select
.ClearFormats 'Fomate löschen
.ClearContents 'Inhalt löschen
End With
'Linke Zellen zusammen führen
Range("AD6:AD113").Formula = _
"=SUBSTITUTE(C6&D6&E6&F6&G6&H6&I6&J6&K6&L6&M6&N6&O6&P6&Q6&R6&S6&T6&U6&V6&W6&X6&Y6&Z6&AA6&AB6&AC6,"" "","""")"
'Rechte Zelle einfügen - Leerzeichen entfernen
Range("AF6:AF113").Formula = "=SUBSTITUTE(AG6,"" "","""")"
'vergleichsformel
Range("AE6:AE113").Formula = "=IF(AD6<>AF6,TRUE(),"""")"
'Formel in Werte umwandeln
Range("AD6:AF113") = Range("AD6:AF113").Value
'Vergleiche Spalte AD und AF
On Error Resume Next
Set rng = Range("AE6:AE113").SpecialCells(xlCellTypeConstants, xlLogical)
On Error GoTo 0
If Not rng Is Nothing Then rng.Interior.Color = vbRed
'Range("AD6:AF113").ClearContents
Set rng = Nothing
End Sub
Dan werden die Werte gleich richtig formatiert und ohne zusätzliche Leerzeichen eingetragen
und bei der Überprüfung werden Leerzeichen die zwischen Weten stehen auch eliminiert.