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

MMasiarek

New Member
Joined
Mar 2, 2021
Messages
7
Office Version
  1. 365
  2. 2019
Platform
  1. Windows
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'
VBA Code:
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:
VBA Code:
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

Active Member
Joined
Jul 30, 2012
Messages
417
Office Version
  1. 2016
Platform
  1. Windows
In the new Worksheet_Change you are calling macro "CopyPasteMulti", where is it ?
 

Some videos you may like

Excel Facts

Highlight Duplicates
Home, Conditional Formatting, Highlight Cells, Duplicate records, OK to add pink formatting to any duplicates in selected range.

MMasiarek

New Member
Joined
Mar 2, 2021
Messages
7
Office Version
  1. 365
  2. 2019
Platform
  1. Windows
In the new Worksheet_Change you are calling macro "CopyPasteMulti", where is it ?
So my idea was to make it that way:

VBA Code:
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
VBA Code:
Sub CopyPasteMulti(xTarget)
to create new row in Log sheet when I for example insert new row in sheet Magazyn

Use
VBA Code:
Sub CopyPaste()
to create new row in Log sheet when I change something in one cell in sheet Magazyn
 

rollis13

Active Member
Joined
Jul 30, 2012
Messages
417
Office Version
  1. 2016
Platform
  1. Windows
Let's see if I rewrote correctly these tre macros (didn't test thoroughly :cool:):
VBA Code:
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

Active Member
Joined
Jul 30, 2012
Messages
417
Office Version
  1. 2016
Platform
  1. Windows
PS. I also made a minor change here:
Code:
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
 

Watch MrExcel Video

Forum statistics

Threads
1,127,998
Messages
5,628,046
Members
416,289
Latest member
Jbelisari

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Top