Excel VBA - Zeilen auf Inhalt überprüfen und duplizieren

office365-CH

Grünschnabel
Hallo zusammen

Ich erhalte eine Excelliste mit 17 Spalten und unterschiedlichen Anzahl Zeilen. Es handelt sich dabei um einen Export einer Kassenabrechnung.
Pro Zeile ist ein Arbeitstag mit den Verkaufsumsätzen etc.

In der Spalte C sind Umsätze der MWST 8.0., in Spalte E 3.5% (Schweiz), in der Spalte G sind die Einnahmen in bar und in der Spalte H sind die Einnahmen per Kredikarte vorhanden.

Ziel ist es nun pro Zeile zu prüfen, ob in der Spalte H (Kreditkarte) ein Wert vohanden ist, wenn ja, dann ist die gesamte Zeile zu kopieren und der Wert der Spalte H ist in die Spalte G zu kopieren.
Dies ist nötig, damit im Buchhaltungssystem jede Zahlung einzeln eingelesen werden kann.

Hierzu bin ich für jeden Tipp/Hilfestellung dankbar!

Herzlichst.
 
Dann hast du die Einnamen aber doppelt verbucht. Oder nicht?

Egal. So gehts
Visual Basic:
Option Explicit

'-------------------------------------------------------------------------------
' -- ! SETTINGS !
'-------------------------------------------------------------------------------

'Spalte der Einnamen
Const C_EINNAHMEN_COL = "G"

'Spalte der Kreditkarteneinnahmen
Const C_CREDIT_CARD_COL = "H"

'Erste Datenzeile.
Const C_FIRST_DATA_ROW = 2

'Name des Worksheets
Const C_SHEET_NAME = "Sheet1"

'-------------------------------------------------------------------------------
' -- Public methodes
'-------------------------------------------------------------------------------

'/**
' * Kopiert die Kreditkarteneinträge als neue Buchung
' * Created by ERB software / http://wiki.yaslaw.info
' * @param  Name des Excelsheets
' */
Public Sub copyCreditCardPayment()
    Dim ws As Worksheet
    Dim rowNr As Long
    Dim creditCardValue As Double
    Dim lastRowNrBeforeCopyJob As Long
   
    Set ws = ThisWorkbook.Sheets(C_SHEET_NAME)
   
    'Letzte Zeile vor dem Copy-Job ermitteln
    lastRowNrBeforeCopyJob = xlsGetLastRow(ws)
   
    'Von unten nach oben abarbeiten, damit die Position nicht jedesmal verschoben wird
    For rowNr = lastRowNrBeforeCopyJob To 2 Step -1
        'Betrag des Kreditkartenbetrages auselsen
        creditCardValue = ws.Cells(rowNr, C_CREDIT_CARD_COL).value
        'Püfen ob eine Kreditkartenzahlung erfolgt ist
        If Not (creditCardValue = Empty Or creditCardValue = 0) Then
            'Zeile Kopieren und unterhalb einfügen
            ws.Rows(rowNr).Copy
            ws.Rows(rowNr + 1).Insert Shift:=xlDown
            'Einnahmefelder umbuchen
            ws.Cells(rowNr + 1, C_EINNAHMEN_COL) = creditCardValue
            ws.Cells(rowNr + 1, C_CREDIT_CARD_COL) = Empty
        End If
    Next rowNr
   
    'Speicher aufräumen
    Set ws = Nothing
End Sub

'-------------------------------------------------------------------------------
' -- Private Libraries
'-------------------------------------------------------------------------------

'/**
' * ermitteln der letzten gefüllten Zeile eines Worksheets
' * Die Funktion Sheet.Cells.SpecialCells(xlCellTypeLastCell) liefert auch instanzierte Zeilen ohne Inhalt
' * http://wiki.yaslaw.info/wikka/vbaExcelGetLastRowCol
' * Created by ERB software / http://wiki.yaslaw.info
' * @param  Worksheet               Eine Referenz auf das Worksheet
' * @return Long                    Zeilenindex der letzten Zeile mit Inhalt
' */
Private Function xlsGetLastRow(ByRef Sheet As Excel.Worksheet) As Long
    Dim r As Variant
    xlsGetLastRow = Sheet.Cells.SpecialCells(xlCellTypeLastCell).Row
    For r = xlsGetLastRow To 1 Step -1
        If Sheet.Application.WorksheetFunction.CountA(Sheet.Rows(r)) = 0 Then
            xlsGetLastRow = r - 1
        Else
            Exit For
        End If
    Next r
End Function
 
Zurück