Hallo zusammen,
ich möchte im Blatt "Tabelle 1" folgende Funktion kreien: Der Bereich M3:M1000 soll als Art Eingabe-Maske fungieren, dort sind tlw. Daten eingetragen und der Rest leere Zellen. Ab Spalte N beginnt dann quasi die "Werte-Datenbank". Via Makro-Button (ist angelegt) soll dieser Bereich Zelle für Zelle von oben nach unten abgefragt werden: Wenn in Zelle Wert vorhanden, dann Wert ausschneiden und in der nächsten leeren Zelle rechts davon (gleiche Zeile) einfügen. Da ab Spalte N tlw dort schon Daten eingetragen sind, kann dies pro Zeilennummer dann eine andere Spalte sein.
Mein Versuch funktioniert nicht:
Sub WertUebertragen2() 'Wenn in Spalte M(13) leere Zelle, dann ausschneiden und rechts einfügen...
Dim Last As Integer
Dim i As Long
i = 3
Last = Cells(i, Columns.Count).End(xlToLeft).Column + 1
Do While i < 1000
If Cells(i, 13) <> "" Then
Cells(i, 13).Cut Destination:=Cells(i, Last)
Application.CutCopyMode = False
End If
i = i + 1
Loop
End Sub
Bei meinem Versuch hier ist das Problem, dass die zuerst gefundene Spalte, wohin eine Ausschneiden-Einfügen-Aktion gemacht wurde, dann leider für alle folgenden Zeilen in der gleichen Spalte resuliert. Dabei werden leider Daten überschrieben. Nach 1,5 Tagen knobeln hoffe ich, dass ihr mir her weiterhelfen könnt.
Statt Ausschneiden würde auch noch kopieren + einfügen gehen und danach den ursprünglichen Wert in Spalte M löschen, dann nächste Zeile. Dies hätte den Vorteil, dass meine Formatierung (vom Ausschneiden) nicht verloren geht (von oben nach unten immer ein Dreier-Satz: Datum, Preis, Text (Name Lieferant)).
Hier eine andere Version, die aber nicht funktioniert, Debugger meldet sich.
Sub WerteNachRechts()
'sucht Bereich M3:M1000 nach gefüllten Zellen ab, wenn gefüllt, dann kopieren +
'einfügen in nächste leere Zelle in gleicher Zeile
Dim rg As Range: Set rg = ActiveSheet.Range("M3:M1000")
Dim i As Long
Dim lastRow As Long ': Set lastRow = rg.Cells(Rows.Count, 13).End(xlUp).Row
Dim Last As Integer ': Set Last = rg.Cells(i, Columns.Count).End(xlToLeft).Column + 1
lastRow = Cells(Rows.Count, 13).End(xlUp).Row
Last = Cells(i, Columns.Count).End(xlToLeft).Column + 1
For Each Cell In rg
'For i = 3 To lastRow
If rg.Cells(i, 13) <> "" Then 'Range vor .Cells entfernt
rg.Cells(i, 13).Cut Destination:=Cells(i, Last)
'Cells(i, Last).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
Application.CutCopyMode = False
'Range(Cells(i, 2), Cells(i, 3)).Interior.ColorIndex = 3
End If
Next Cell 'i ausgetauscht durch Zelle
End Sub
Danke für eure Hilfe und Anregungen. Gruß, Nadine
(Excel2019, VBA Grundkenntnisse, aber mehr "Trial & Error")
|