Hello everyone,
I have an excel workbook with four sheets:
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'
Below I attached whole code I'm using in a workbook:
Could you help me with find a way to prevent multipling rows in sheet 'Log'?
I have an excel workbook with four sheets:
- Magazyn
- Log
- WZD
- PZD
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'?