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

M

MMasiarek

New Member
Joined
Mar 2, 2021
Messages
20
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'?
 

Excel Facts

How to total the visible cells?
From the first blank cell below a filtered data set, press Alt+=. Instead of SUM, you will get SUBTOTAL(9,)
Sort by date Sort by votes
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
 
Upvote 0
rollis13 said:
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
Click to expand...
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'.
 
Upvote 0
rollis13 said:
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
Click to expand...
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
 
Upvote 0
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
 
Upvote 0
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'
 
Upvote 0
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
 
Upvote 0
Solution
Great! Now it looks like everything works fine.
Thank you very much for help :)
 
Upvote 0
rollis13 said:
Glad I was able to help (y).
Click to expand...
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?
 
Upvote 0
You must log in or register to reply here.

Similar threads

F
  • Solved
VBA set conditional formatting application-defined or object-defined error
Replies
3
Views
67
Cubist
C
H
  • Solved
problem with code- removing duplicate rows
Replies
2
Views
133
heathball
H
S
  • Question
VBA: All Sheets data to Master Sheet (excluding some sheet)
2
Replies
11
Views
379
kevin9999
K
D
  • Question
Data from one sheet to overide data on another sheet
Replies
0
Views
177
Daroh
D
A
  • Solved
Remove duplicates keep formatting
Replies
1
Views
206
Aqusmacro
A

Forum statistics

Threads
1,214,606
Messages
6,120,488
Members
448,967
Latest member
visheshkotha

Share this page

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
Back
Top