VBA Daten übertragen wenn X

Hallo Zusammen,
ich benötige euere Hilfe.
In der Beispieldatei gibt es einen Reiter Quelle und und einen MA A.
Wenn in dem Reiter Quelle in Spalte G ein "x" eingetragen ist, soll er Spalte B, C, D und G übernehmen.
Wenn kein "x" dann nichts machen.
Davor sollte er prüfen ob es die Nr. (Spalte B) schon gibt, heißt die Daten sind schon im Reiter MA A vorhanden, wenn ja soll er nichts machen, wenn nicht soll er sie übernehmen.
Andersrum wenn es im MA A Reiter Daten gibt die es in der Quelle nicht gibt, bzw. nicht mit "x" gekennzeichnet sind soll er die Zeile löschen.
Versteht ihr was ich meine? Entschuldigt, ich weiß ich drücke mich oft etwas kompliziert aus :)
https://www.herber.de/bbs/user/143972.xlsx
Vielen lieben Dank im Voraus ihr Lieben!

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Sub Abgleichen() Dim letzteZeileM As Long Dim letzteZeileQ As Long Dim nr As Long Dim wsM As Worksheet Dim wsQ As Worksheet Dim zeileM As Long Dim zeileQ As Long Set wsM = ThisWorkbook.Worksheets("MA A") Set wsQ = ThisWorkbook.Worksheets("Quelle") letzteZeileM = wsM.Cells(wsM.Rows.Count, "B").End(xlUp).Row If letzteZeileM "x" Then wsM.Rows(zeileM).Delete End If End If Next zeileM ' Sätze von "Quelle" nach "MA A" letzteZeileM = wsM.Cells(wsM.Rows.Count, "B").End(xlUp).Row If letzteZeileM

Hallo Mone,
teste mal:

Option Explicit

Public Sub UpdateData()

    Dim lngRow As Long, lngEmptyRow As Long
    Dim objCell As Range

    With Worksheets("Quelle")

        For lngRow = 7 To .Cells(.Rows.Count, 2).End(xlUp).Row

            If .Cells(lngRow, 7).Value = "x" Then

                Set objCell = Worksheets("MA A").Columns(2).Find( _
                    What:=.Cells(lngRow, 2).Value, LookIn:=xlValues, LookAt:=xlWhole)

                If objCell Is Nothing Then

                    With Worksheets("MA A")

                        lngEmptyRow = .Cells(.Rows.Count, 2).End(xlUp).Offset(1, 0).Row

                    End With

                    Worksheets("MA A").Cells(lngEmptyRow, 2).Value = .Cells(lngRow, 2).Value
                    Worksheets("MA A").Cells(lngEmptyRow, 3).Value = .Cells(lngRow, 3).Value
                    Worksheets("MA A").Cells(lngEmptyRow, 4).Value = .Cells(lngRow, 4).Value
                    Worksheets("MA A").Cells(lngEmptyRow, 5).Value = .Cells(lngRow, 7).Value

                Else
                    Set objCell = Nothing
                End If
            End If
        Next
    End With

    With Worksheets("MA A")

        For lngRow = 7 To .Cells(.Rows.Count, 2).End(xlUp).Row

            Set objCell = Worksheets("Quelle").Columns(2).Find( _
                What:=.Cells(lngRow, 2).Value, LookIn:=xlValues, LookAt:=xlWhole)

            If objCell Is Nothing Then

                Call .Rows(lngRow).Delete

            Else

                If IsEmpty(objCell.Offset(0, 5).Value) Then _
                    Call .Rows(lngRow).Delete

                Set objCell = Nothing

            End If
        Next
    End With
End Sub

Gruß
Nepumuk

Beliebteste Forumthreads (12 Monate)

10 Beiträge zum Forumthread Beiträge zu diesem Forumthread

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

10
Beiträge zum Forumthread

Beiträge zu diesem Forumthread