|
Hallo! HIer mal ein Code. Der teil vom Löschen ist fest vorgegeben. Den müsste man noch anpassen bzw. automatisieren. Vg
Option Explicit
Sub umformen()
Dim letzteZeile
Dim i As Long
Dim spalte As Long
Dim neuZeile As Long
Dim neuSpalte As Long
'suchen bis wohin die Zellen durchsucht werden sollen
letzteZeile = 0
For spalte = 1 To 5
letzteZeile = ActiveSheet.Cells(Rows.Count, spalte).End(xlUp).Row
Next spalte
'alte Eintragungen löschen, muss noch angepasst werden bzw. automatisiert werden
ActiveSheet.Range(ActiveSheet.Cells(1, 8), ActiveSheet.Cells(1000, 20)).ClearContents
neuZeile = 0
neuSpalte = 0
'allte zeilen durchgehen
For i = 1 To letzteZeile
If ActiveSheet.Cells(i, 1) <> "" And ActiveSheet.Cells(i, 4) = "" Then
' nur Datum eingetragen
neuZeile = neuZeile + 1
ActiveSheet.Cells(neuZeile, 8) = ActiveSheet.Cells(i, 1)
ElseIf ActiveSheet.Cells(i, 1) <> "" And ActiveSheet.Cells(i, 2) <> "" Then
'Name Vorname eingetragen
neuZeile = neuZeile + 1
ActiveSheet.Cells(neuZeile, 8) = ActiveSheet.Cells(i, 1)
ActiveSheet.Cells(neuZeile, 9) = ActiveSheet.Cells(i, 2)
ActiveSheet.Cells(neuZeile, 11) = ActiveSheet.Cells(i, 4) & " - " & ActiveSheet.Cells(i, 5)
ElseIf ActiveSheet.Cells(i, 1) = "" And ActiveSheet.Cells(i, 4) <> "" And ActiveSheet.Cells(i, 5) <> "" Then
'Die Werte stehen drin
neuSpalte = ActiveSheet.Cells(neuZeile, Columns.Count).End(xlToLeft).Column
ActiveSheet.Cells(neuZeile, neuSpalte + 1) = ActiveSheet.Cells(i, 4) & " - " & ActiveSheet.Cells(i, 5)
Else
'nichts eingetragen also nix machen
End If
Next i
End Sub
|