AW: Auslesen Zellen mit Zeilenumbruch
09.05.2023 14:29:20
Pappawinni
Ich habs jetzt doch nochmal inplace probiert....
Für die Testdaten jedenfalls sieht das Ergebnis nicht so schlecht aus.
Sub MyCSVRepair()
Dim i As Long
Dim lastRow As Long
Dim lastCol As Long
Dim lngL As Long
Dim lngP As Long
Dim bolFound As Boolean
Dim rngS As Range
Dim oCell As Range
Dim strDecChar As String
Dim strTestNum As String
Dim wsA As Worksheet
Dim aF() As Variant
strDecChar = IIf(IsNumeric(",1"), ",", ".")
strtoreplchar = IIf(IsNumeric(",1"), ".", ",")
Set wsA = ThisWorkbook.Sheets("Sheet1")
lastRow = wsA.UsedRange.End(xlDown).Row
lastCol = wsA.UsedRange.Columns.Count
ReDim aF(lastCol)
i = 1
Do
DoEvents
Set rngS = Range(wsA.Cells(i, 1), wsA.Cells(i, lastCol))
bolFound = False
For Each oCell In rngS
bolFound = IIf(InStr(oCell.Value, vbLf) > 0, True, False)
If bolFound Then Exit For
Next
If bolFound Then
i = i + 1
wsA.Rows(i).Insert
For Each oCell In rngS
If InStr(oCell.Value, vbLf) Then
oCell.Offset(1, 0).Value = Split(oCell.Text, vbLf)(1)
oCell.Value = Split(oCell.Value, vbLf)(0)
Else
If oCell.VerticalAlignment = xlBottom Then
oCell.Offset(1, 0).Value = oCell.Value
oCell.Value = ""
End If
End If
If oCell.MergeCells Then
oCell.UnMerge
lngL = Len(oCell.Value)
lngP = InStrRev(oCell.Value, " ")
strTestNum = Replace(Right(oCell.Value, lngL - lngP), strtoreplchar, strDecChar)
If IsNumeric(strTestNum) Then
oCell.Offset(0, 1).FormulaLocal = strTestNum
oCell.Value = IIf(lngP > 0, Left(oCell.Value, lngP - 1), "")
End If
lngL = Len(oCell.Offset(1, 0).Value)
lngP = InStrRev(oCell.Offset(1, 0).Value, " ")
strTestNum = Replace(Right(oCell.Offset(1, 0).Value, lngL - lngP), strtoreplchar, strDecChar)
If IsNumeric(strTestNum) Then
oCell.Offset(1, 1).FormulaLocal = strTestNum
oCell.Offset(1, 0).Value = IIf(lngP > 0, Left(oCell.Offset(1, 0).Value, lngP - 1), "")
End If
End If
Next
With rngS.Offset(1, 0).EntireRow
.WrapText = False
.HorizontalAlignment = xlGeneral
.VerticalAlignment = xlCenter
.AutoFit
End With
Else
For Each oCell In rngS
If oCell.MergeCells Then
oCell.UnMerge
lngL = Len(oCell.Value)
lngP = InStrRev(oCell.Value, " ")
strTestNum = Replace(Right(oCell.Value, lngL - lngP), strtoreplchar, strDecChar)
If IsNumeric(strTestNum) Then
oCell.Offset(0, 1).FormulaLocal = strTestNum
oCell.Value = IIf(lngP > 0, Left(oCell.Value, lngP - 1), "")
End If
Else
If Not IsEmpty(oCell.Value) Then
aF(oCell.Column - 1) = oCell.NumberFormat
End If
End If
Next
End If
With rngS.EntireRow
.WrapText = False
.VerticalAlignment = xlCenter
.HorizontalAlignment = xlGeneral
.AutoFit
End With
lastRow = wsA.UsedRange.End(xlDown).Row
If i = lastRow Then
For Each oCell In rngS
If Not aF(oCell.Column - 1) = "" Then
oCell.EntireColumn.NumberFormat = aF(oCell.Column - 1)
End If
Next
End If
i = i + 1
Loop Until i > lastRow
End Sub