Excel VBA - prüfen, ob Zelle gefüllt, falls ja; neue Zeile einfügen und Werte kopieren.

Mr. Z-Buffer

Grünschnabel
Hallo,
ich versuche gerade meine ersten Gehversuche in Excel und VBA.

Folgendes Szenario ist gegeben:

In einer Arbeitsmappe habe ich eine Tabelle erstellt (damit man alle werte filtern kann).
Die Überschrift der Tabelle steht ab Zeile 2 (erste Einträge ab Zeile 3).
Die Tabelle erstreckt sich derzeit von Spalte A bis Spalte R (18 Spalten).
Die Spalten sind mit unterschiedlichen Werten gefüllt (teils Text, Teils Zahlen, teils Formeln usw).
Pro Zeile ist aber nicht jede Spalte gefüllt.
Spalte K und L gehören zusammen - genau wie Spalte M und N; O und P (in der Einen steht eine Menge und in der Anderen der Preis)

Folgende Problematik:
Sobald ein Wert in Spalte M einer Zeile (z.B. M4 [was in der Tabelle die 2. Zeile entspricht]) hinterlegt ist, soll unter dieser Zeile eine neue Zeile eingefügt werden.
In diese neue Zeile soll die komplette Zeile, in der ein Wert in M gefunden wurde, hineinkopiert und der Wert aus M4 in K5 und, der Wert aus N4 in L5 kopiert werden.
Weiterhin soll in der Fundzeile (M4 und N4) der Wert gelöscht werden.
Dies soll im Anschluss auch mit den Spalten O und P passieren.

Endergebnis:
Datensätze, welche mehr als eine Auflage haben, sollen die Auflagen und die Preise nicht mehr horizontal in einer Zeile, sondern Vertikal in mehrer Zeilen stehen.
Die Auflagen und die Preise stehen im Anschluss nicht mehr in je 3 Spalten sondern untereinander in nur noch je einer Spalte.

Mein Code sieht bis jetzt so aus (Das Suchen der Einträge und einfügen neuer Zeilen funktioniert sehr gut - okay, der Code sieht nicht sehr schön aus-
Nur möchte ich nicht Zelle für Zelle kopieren und löschen, da schreibe ich mir ja die Finger wund.:

Sub aufr()

n = 3 'Startpunkt der Suche, da sonst die Tabellenüberschrift auch kopiert werden würde

Do 'Schleifen beginn, bis ich beim letzten Eintrag der Tabelle angelangt bin

If Not Cells(n, 15).Value = Empty Then
Cells(n + 1, 15).EntireRow.Insert
Aufl3 = Cells(n, 15)
preis3 = Cells(n, 16)
Cells(n, 15) = Empty
Cells(n, 16) = Empty
Cells(n + 1, 11).Value = Aufl3
Cells(n + 1, 12).Value = preis3
End If

If Not Cells(n, 13).Value = Empty Then
Cells(n + 1, 13).EntireRow.Insert
Aufl2 = Cells(n, 13)
preis2 = Cells(n, 14)
Cells(n, 13) = Empty
Cells(n, 14) = Empty
Cells(n + 1, 11).Value = Aufl2
Cells(n + 1, 12).Value = preis2
End If

n = n + 1

Loop Until n = Range("m65536").End(xlUp).Row + 1

End Sub


Danke für die Hilfe.

Viele Grüße
Buffer
 
Zuletzt bearbeitet:
Der Trick besteht eigentlich darin, das von Unten nach Oben durchzugehen. Somit ist es während dem Loop egal. wieviele Zeilen entstehen

Visual Basic:
Option Explicit

Enum colLetters
    K = 11
    L = 12
    M = 13
    N = 14
End Enum


Public Function test()
    Dim ws As Worksheet
    Dim rowNr As Long
    
    Set ws = Worksheets("Sheet1")
    
    For rowNr = xlsGetLastRow(ws) To 3 Step -1
        
        If ws.Cells(rowNr, M).Value <> "" Then
            ws.Rows(rowNr).Copy
            ws.Rows(rowNr + 1).Insert xlDown
            Application.CutCopyMode = False
            
            move ws.Rows(rowNr + 1), M, K
            move ws.Rows(rowNr + 1), N, L
        End If
    
    Next
    
End Function

Private Function move(ByRef ioRow As Range, ByVal iFromCol, ByVal iToCol)
    ioRow.Cells(1, iToCol).Value = ioRow.Cells(1, iFromCol).Value
    ioRow.Cells(1, iFromCol).Value = Empty
End Function


'/**
' * Ermittelt die letzte gefüllte Zeile eines Worksheets
' * @param  Worksheet   Das Worksheetobjekt, das durchsucht werden soll
' * @return Long        Die Zeilennummer. Wenn das ganze Sheet leer ist, ist der Rückgabewert 0
' */
Public Function xlsGetLastRow(ByRef sheet As Object) As Long
    Const xlCellTypeLastCell = 11

    'Zur letzten initialisierten Zeile gehen
    xlsGetLastRow = sheet.Cells.SpecialCells(xlCellTypeLastCell).Row
    
    'Von dort zurücksuchen bis zur Letzten zeile mit Inhalt
    Do While sheet.Application.WorksheetFunction.CountA(sheet.Rows(xlsGetLastRow)) = 0 And xlsGetLastRow > 1
        xlsGetLastRow = xlsGetLastRow - 1
    Loop
End Function
 
Sauber, das ging schnell. Danke.

Leider hatte ich vergessen zu erwähnen, dass das alles erst passieren soll, wenn man auf eine Schaltfläche eines Formularsteuerelementes klickt. In diesem Falle heißt das Ding "aufr".

wenn Ich nun den Code in die Sub aufr() kopiere und auf die Schaltfläche klicke,
sagt er sofort, dass "Option Explicit" innerhalb einer Prozedur ungültig ist.

Viele Grüße
Buffer
 
Du kannst nicht einfach alles da reinkopieren.

Mein Code beinhaltet eine Header-Info, einem Enum und 3 Funktionen die alle gerne auf oberster Stufe sind.
Zudem ist mein Cod nur ein Test und muss noch angepasst werden.

Ist ein kleines VBA-Einmaleins.
Die Excel-VBA Hilfe und Google helfen dir gut weiter, was es mit Option Explicit und mit Enum auf sich hat.
 
Das werde ich heute Abend versuchen umzusetzen.
Aber wie gesagt, ich habe heute Morgen erst mit VBA-Programmierung angefangen, sind meine ersten Gehversuche.
Ich muss mich da in einiges einlesen.

Danke für die Hilfe.

Viele Grüße
Buffer
 
Achso, Am Einfachsten kopierst du mein Gerümpel in ein eigenes Modul.
Benennst meine Funktion test() zu etwas Sinnvollem um.
Dann kannst du mit dem Button diese Funktion ansteuern.
Natürlich muss sie noch um weitere move() erweitert werden.

Ich empfehle dir, Option Explicit in jedem Modul als erste Zeile einzufügen. Das zwingt dich dazu, jede Variable zu deklarieren. Dafür hast du keine komischen Fehler wenn du mal rwoNr anstelle von rowNr schreibst, weil dann Excel bereits ausruft, dass rwoNr nicht deklariert sei. Ansonsten geht der Code einfach durch und nimmt rwoId mit dem Wert empty.
 
Gut, bis auf das Wort "Gerümpel" hab ich so gut wie nichts verstanden.... und das Option Explicit überall stehen soll (Außer in einer Prozedur, offensichtlich geht das dort nicht ^^)

So, das sollte es erstmal gewesen sein.
Danke, Du bist eine sehr große Hilfe.
 
Zurück