Too many rows insert in Sheet2 when change event occures in Sheet1

[MMasiarek]

Hello everyone,

I have an excel workbook with four sheets:

1. Magazyn
2. Log
3. WZD
4. PZD

Workbook functionalities:
If anything changes in columns B:I in sheet 'Magazyn", then the row is saving in sheet 'Log'.
If value in column F in sheet 'Magazyn' changes to 'Biuro' then the row is saving in sheet 'PZD'.
If value in column F in sheet 'Magazyn' changes to anything else than 'Biuro' then the row is saving in sheet 'PZD'.

Second, and third point is working fine, but if I insert a new row(from column B to column I) in sheet 'Magazyn' I'm geting 8 new rows in sheet 'Log'.

Code below is used for copy from sheet 'Magazyn' to sheet 'Log'

Sub CopyPaste(xTarget)

    If Not Intersect(xTarget, Range("B:I")) Is Nothing Then

        LastRow = Sheets("Logi").Cells.Find("*", searchorder:=xlByRows, searchdirection:=xlPrevious).Row + 1
    
        Sheets("Magazyn").Range("A" & xTarget.Row & ":J" & xTarget.Row).Copy Destination:=Sheets("Logi").Range("A" & LastRow)

    End If

End Sub

Below I attached whole code I'm using in a workbook:

Private Sub Worksheet_Change(ByVal Target As Range)
    
    Dim xTarget As Range

For Each xTarget In Target
    CopyPaste xTarget
    CopyPasteWZD xTarget
    CopyPastePZD xTarget
    Confirmation xTarget
Next xTarget

End Sub

Sub CopyPaste(xTarget)

    If Not Intersect(xTarget, Range("B:I")) Is Nothing Then

        LastRow = Sheets("Logi").Cells.Find("*", searchorder:=xlByRows, searchdirection:=xlPrevious).Row + 1
    
        Sheets("Magazyn").Range("A" & xTarget.Row & ":J" & xTarget.Row).Copy Destination:=Sheets("Logi").Range("A" & LastRow)

    End If

End Sub

Sub CopyPastePZD(xTarget)
    
    If Not Intersect(xTarget, Range("F:F")) Is Nothing Then
    
        LastRow = Sheets("PZD").Cells.Find("*", searchorder:=xlByRows, searchdirection:=xlPrevious).Row + 1
    
        If xTarget.Value = "Biuro" Then
            Sheets("Magazyn").Range("A" & xTarget.Row & ":J" & xTarget.Row).Copy Destination:=Sheets("PZD").Range("A" & LastRow)
        End If
    
    End If
    
End Sub

Sub CopyPasteWZD(xTarget)

    If Not Intersect(xTarget, Range("F:F")) Is Nothing Then

        LastRow = Sheets("WZD").Cells.Find("*", searchorder:=xlByRows, searchdirection:=xlPrevious).Row + 1

        If xTarget.Value <> "Biuro" Then

            Sheets("Magazyn").Range("A" & xTarget.Row & ":J" & xTarget.Row).Copy Destination:=Sheets("WZD").Range("A" & LastRow)
        End If

    End If
End Sub

Sub Confirmation(ByVal Target As Range)
    With Target
        If (.Column <> 2 And .Column <> 9) Or .Cells.Count > 1 Then Exit Sub

        If WorksheetFunction.CountIf(Columns(.Column), .Value) > 1 Then
            Application.DisplayAlerts = False
            .ClearContents
            Application.DisplayAlerts = True
            MsgBox "Wprowadzona wartosc juz istnieje"
        End If

    End With
End Sub

Could you help me with find a way to prevent multipling rows in sheet 'Log'?

 

[rollis13]

In the new Worksheet_Change you are calling macro "CopyPasteMulti", where is it ?

 

[MMasiarek]

In the new Worksheet_Change you are calling macro "CopyPasteMulti", where is it ?

So my idea was to make it that way:

Private Sub Worksheet_Change(ByVal Target As Range)

Set myTarget = Target

    Dim xTarget As Range
    For Each xTarget In Target
        CopyPasteMulti xTarget
        CopyPasteWZD xTarget
        CopyPastePZD xTarget
        Confirmation xTarget
    Next xTarget
End Sub

Sub CopyPasteMulti(xTarget)
    If xTarget.Column = 1 Then
        LastRow = Sheets("Logi").Cells.Find("*", searchorder:=xlByRows, searchdirection:=xlPrevious).Row + 1
        Sheets("Magazyn").Range("A" & xTarget.Row & ":J" & xTarget.Row).Copy Destination:=Sheets("Logi").Range("A" & LastRow)
    End If
End Sub

Sub CopyPaste()
    If Not Intersect(myTarget, Range("A:J")) Is Nothing Then
        LastRow = Sheets("Logi").Cells(Rows.Count, "A").End(xlUp).Row + 1
        Sheets("Magazyn").Range("A" & myTarget.Row & ":J" & myTarget.Row).Copy Destination:=Sheets("Logi").Range("A" & LastRow)
    End If

End Sub

Use

Sub CopyPasteMulti(xTarget)

to create new row in Log sheet when I for example insert new row in sheet Magazyn

Use

Sub CopyPaste()

to create new row in Log sheet when I change something in one cell in sheet Magazyn

 

[rollis13]

Let's see if I rewrote correctly these tre macros (didn't test thoroughly ):

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim xTarget As Range
    If Intersect(Target, Range("A:J")) Is Nothing Then Exit Sub
    If Target.count = 1 Then CopyPaste Target     'for single cell
    For Each xTarget In Target
        If Target.count > 1 And xTarget.Column = 1 Then CopyPasteMulti xTarget 'for entire row(s)
        CopyPasteWZD xTarget
        CopyPastePZD xTarget
        Confirmation xTarget
    Next xTarget
End Sub

Sub CopyPaste(Target)                             'for single cell
    Dim lastrow As Long
    lastrow = Sheets("Logi").Cells(Rows.count, "A").End(xlUp).Row + 1
    Sheets("Magazyn").Range("A" & Target.Row & ":J" & Target.Row).Copy Destination:=Sheets("Logi").Range("A" & lastrow)
End Sub

Sub CopyPasteMulti(xTarget)                       'for entire row(s)
    Dim lastrow As Long
    lastrow = Sheets("Logi").Cells.Find("*", searchorder:=xlByRows, searchdirection:=xlPrevious).Row + 1
    Sheets("Magazyn").Range("A" & xTarget.Row & ":J" & xTarget.Row).Copy Destination:=Sheets("Logi").Range("A" & lastrow)
End Sub

 

[rollis13]

PS. I also made a minor change here:

Sub Confirmation(Target)                          '<=changed
    With Target
        If (.Column <> 2 And .Column <> 9) Or .Cells.count > 1 Then Exit Sub
        If WorksheetFunction.CountIf(Columns(.Column), .Value) > 1 Then
            Application.DisplayAlerts = False
            Application.EnableEvents = False
            .ClearContents
            Application.EnableEvents = True
            Application.DisplayAlerts = True
            MsgBox "Wprowadzona wartosc juz istnieje"
        End If
    End With
End Sub