VBA - beim Kopieren Format nicht ändern
14.04.2026 21:45:29
Christian
ich bitte euch um Hilfe bei etwas, bei dem selbst ChatGPT am verzweifeln ist...
Die Datei lässt sich leider wegen 30 MB schwer hochladen und der Löwenanteil wird auch für das Makro gebraucht,
aber vielleicht hat ja doch jemand eine Idee.
For i = 1 To lastRow
Dim cellValue As Variant
cellValue = ws.Cells(i, 4).Value
If cellValue = 1 Then
textB = ws.Cells(i, 2).Value
count2 = 0
For k = i + 1 To lastRow
If ws.Cells(k, 4).Value = 2 Then count2 = count2 + 1 Else Exit For
Next k
If count2 > 0 Then neuesBlatt.Cells(freieZeile, 3).Resize(count2, 1).Value = UCase(textB)
ElseIf cellValue = 3 Then
textC = ws.Cells(i, 3).Value
countVorDrei = 0
For k = i - 1 To 1 Step -1
If ws.Cells(k, 4).Value = 2 Then countVorDrei = countVorDrei + 1 Else Exit For
Next k
If countVorDrei > 0 Then
neuesBlatt.Cells(freieZeile, 1).Resize(countVorDrei, 1).Value = UCase(textC)
freieZeile = freieZeile + countVorDrei
End If
End If
Next i
targetRow = ersteFreieZeile
For i = 1 To lastRow
If ws.Cells(i, 4).Value = 2 Then
neuesBlatt.Cells(targetRow, 2).Value = UCase(ws.Cells(i, 3).Value)
targetRow = targetRow + 1
End If
Next i
' Duplikate nach jedem Blatt entfernen
Dim lrAlle As Long
lrAlle = neuesBlatt.Cells(neuesBlatt.Rows.count, "A").End(xlUp).Row
If lrAlle > 1 Then
With neuesBlatt
.Range("A1:C" & lrAlle).RemoveDuplicates Columns:=Array(2, 3), Header:=xlNo
End With
End If
das mal der betreffende Codeabschnitt. Mein Problem ist wie bekomme ich es hin, dass die Dinge die in Spalte A des neuen Blatts geschrieben werden, wirklich 1:1 übernommen werden, also z.b. nicht aus 12/12/12 der 12.12.2012 gemacht wird oder aus SEPTEMBER 1923 der 01.09.1923 oder aus 3% 0,03.
Um nur ein paar Beispiele zu nennen.
Danke
Christian
Anzeige