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'?
 

Some videos you may like

Excel Facts

Copy PDF to Excel
Select data in PDF. Paste to Microsoft Word. Copy from Word and paste to Excel.

rollis13

Active Member
Joined
Jul 30, 2012
Messages
414
Office Version
  1. 2016
Platform
  1. Windows
That happens because in macro "Private Sub Worksheet_Change(ByVal Target As Range)" you are using "For Each xTarget In Target" so if you insert a new row (from column B to column I) in sheet 'Magazyn' it will loop 8 times, once for every cell from column B to I and add 8 new rows in sheet 'Logi'.
I added a boolean test to launch macro 'CopyPaste' only once when you copy more then 1 cell at the time.
See if it does the job.
VBA Code:
Private Sub Worksheet_Change(ByVal Target As Range)
    Dim xTarget As Range
    Dim count  As Boolean
    For Each xTarget In Target
        If count = False Then CopyPaste xTarget: count = True
        CopyPasteWZD xTarget
        CopyPastePZD xTarget
        Confirmation xTarget
    Next xTarget
End Sub
 

MMasiarek

New Member
Joined
Mar 2, 2021
Messages
7
Office Version
  1. 365
  2. 2019
Platform
  1. Windows
That happens because in macro "Private Sub Worksheet_Change(ByVal Target As Range)" you are using "For Each xTarget In Target" so if you insert a new row (from column B to column I) in sheet 'Magazyn' it will loop 8 times, once for every cell from column B to I and add 8 new rows in sheet 'Logi'.
I added a boolean test to launch macro 'CopyPaste' only once when you copy more then 1 cell at the time.
See if it does the job.
VBA Code:
Private Sub Worksheet_Change(ByVal Target As Range)
    Dim xTarget As Range
    Dim count  As Boolean
    For Each xTarget In Target
        If count = False Then CopyPaste xTarget: count = True
        CopyPasteWZD xTarget
        CopyPastePZD xTarget
        Confirmation xTarget
    Next xTarget
End Sub
It seems to work, but only for the first insert of row/rows. If I insert row B2:I2 it will occur in sheet 'Log' once. Then I want to insert another row B3:I3, this one is not appearing in sheet 'Log'.
 

MMasiarek

New Member
Joined
Mar 2, 2021
Messages
7
Office Version
  1. 365
  2. 2019
Platform
  1. Windows
That happens because in macro "Private Sub Worksheet_Change(ByVal Target As Range)" you are using "For Each xTarget In Target" so if you insert a new row (from column B to column I) in sheet 'Magazyn' it will loop 8 times, once for every cell from column B to I and add 8 new rows in sheet 'Logi'.
I added a boolean test to launch macro 'CopyPaste' only once when you copy more then 1 cell at the time.
See if it does the job.
VBA Code:
Private Sub Worksheet_Change(ByVal Target As Range)
    Dim xTarget As Range
    Dim count  As Boolean
    For Each xTarget In Target
        If count = False Then CopyPaste xTarget: count = True
        CopyPasteWZD xTarget
        CopyPastePZD xTarget
        Confirmation xTarget
    Next xTarget
End Sub
What I'm trying to get is:

This is my 'Magazyn' sheet. All three rows were pasted in one copy-paste operation
Magazyn v1.xlsm
ABCDEFGHIJ
1Numer umowyImeiRodzaj urządzeniaRodzaj umowySTATUS LokalizacjaNazwa monteraNazwa Klientanr SIMKomentarz (np. opis usterki)
2a11FM15 (OBD+CAN)ZakupSprawneMonterCAR FOX (KRK)xyz1brak
3a22FLM CANZakupSprawneBiuroCAR FOX (KRK)qwe2xyz
4a103FLM08 Pro CAN+3D (S8.3 3D)ZakupDo SprawdzeniaBiuroAuto Technika Kurkowskiqwe3xyz
Magazyn
Cells with Data Validation
CellAllowCriteria
C2:C25List=Słowniki!$A$2:$A$25
D2:D25List=Słowniki!$B$2:$B$5
E2:E25List=Słowniki!$D$2:$D$7
F2:F25List=Słowniki!$C$2:$C$6
G2:G25List=Słowniki!$E$2:$E$50


And sheet 'Log' should look like this:
Magazyn v1.xlsm
ABCDEFGHIJKLM
1Numer umowyImeiRodzaj urządzeniaRodzaj umowySTATUS LokalizacjaNazwa monteraNazwa Klientanr SIMKomentarz (np. opis usterki) DzieńGodzinaUżytkownik
2a11FM15 (OBD+CAN)ZakupSprawneMonterCAR FOX (KRK)xyz1brak02.03.202120:56:37user1
3a22FLM CANZakupSprawneBiuroCAR FOX (KRK)qwe2xyz02.03.202120:56:37user1
4a103FLM08 Pro CAN+3D (S8.3 3D)ZakupDo SprawdzeniaBiuroAuto Technika Kurkowskiqwe3xyz02.03.202120:56:37user1
Logi
Cells with Data Validation
CellAllowCriteria
C2:C8List=Słowniki!$A$2:$A$25
D2:D8List=Słowniki!$B$2:$B$5
E2:E8List=Słowniki!$D$2:$D$7
F2:F8List=Słowniki!$C$2:$C$6
G2:G8List=Słowniki!$E$2:$E$50
 

rollis13

Active Member
Joined
Jul 30, 2012
Messages
414
Office Version
  1. 2016
Platform
  1. Windows

ADVERTISEMENT

You need to copy/paste only from column B to I if you want macro "CopyPaste(xTarget)" work correctly since you are testing:
If Not Intersect(xTarget, Range("B:I")) Is Nothing Then

Anyway, apply these changes to this other macro, will help to avoid some redundancy in another part of the progect:
VBA Code:
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
            Application.EnableEvents = False      '<= added
            .ClearContents
            Application.EnableEvents = True       '<= added
            Application.DisplayAlerts = True
            MsgBox "Wprowadzona wartosc juz istnieje"
        End If
    End With
End Sub
 

MMasiarek

New Member
Joined
Mar 2, 2021
Messages
7
Office Version
  1. 365
  2. 2019
Platform
  1. Windows
I changed range from B:I to A:J.
But still if I want to paste values in A2:J4 in sheet 'Magazyn'. It will give me only one row in sheet 'Log' with values from A2:J2 from 'Magazyn'
 

rollis13

Active Member
Joined
Jul 30, 2012
Messages
414
Office Version
  1. 2016
Platform
  1. Windows

ADVERTISEMENT

So, if I understood well, when you paste a row (or rows) it (they) will always be from A to J.
If so, resume your originale versione of macro "Worksheet_Change" and change "CopyPaste(xTarget)" like this:
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 xTarget.Column = 1 Then                    '<= changed
        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
 
Solution

MMasiarek

New Member
Joined
Mar 2, 2021
Messages
7
Office Version
  1. 365
  2. 2019
Platform
  1. Windows
Great! Now it looks like everything works fine.
Thank you very much for help :)
 

MMasiarek

New Member
Joined
Mar 2, 2021
Messages
7
Office Version
  1. 365
  2. 2019
Platform
  1. Windows
Glad I was able to help (y).
If I can have one more question?
I tried to add sub which should track changes in single cell, and save changed rows to Log sheet.
For that I changed Worksheet_Change like this

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

and I added this sub, which worked previously:

VBA Code:
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

Do you have an idea where the issue is?
 

Watch MrExcel Video

Forum statistics

Threads
1,127,355
Messages
5,624,207
Members
416,017
Latest member
moritz210

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