PDA

View Full Version : Solved: VBA to identify duplicate entry and insert row to other worksheet



cc9083
05-17-2009, 11:14 PM
I have 3 worksheets and would like to have a VBA to perform a duplicate check on Column B of Sheet 1 and once a non-duplicate is identified, one row shall be inserted in both Sheet 2 and Sheet 3 to accommodate for the non duplicate cell. A duplicate cell shall not initiate any action.

Sheet 1 - Column A, B & C are updated everyday
Sheet 2 - New row to be added for non-duplicate
Sheet 3 - New row to be added for non-duplicate

My Example File is already equipped with 2 macro buttons for inserting row and deleting row. However I need the additional VBA to get my desired result.

mdmackillop
05-21-2009, 05:27 AM
If this is correct, we can tidy up the rest.

Option Explicit
Sub Macro4()
Dim Users1 As Range
Dim Users2 As Range
Dim Users3 As Range
Dim Sh1 As Worksheet
Dim Sh2 As Worksheet
Dim Sh3 As Worksheet
Set Sh1 = Sheets(1)
Set Sh2 = Sheets(2)
Set Sh3 = Sheets(3)
Dim cel As Range, c As Range
Dim FirstAddress As String
Dim i As Long

Sh2.Range("A3").ClearContents
Sh3.Range("A3").ClearContents
With Sh1
Set Users1 = Range(.Cells(3, 2), .Cells(Rows.Count, 2).End(xlUp))
Users1.AdvancedFilter Action:=xlFilterCopy, CopyToRange:=Sh2.Range("A3"), Unique:=True
Users1.AdvancedFilter Action:=xlFilterCopy, CopyToRange:=Sh3.Range("A3"), Unique:=True
End With
With Sh2
Set Users2 = Range(.Cells(5, 1), .Cells(Rows.Count, 1).End(xlUp))
End With
For Each cel In Users2
FirstAddress = ""
i = 1
With Users1
Set c = .Find(cel, LookIn:=xlValues)
If Not c Is Nothing Then
FirstAddress = c.Address
Do
cel.Offset(, i + 1) = c.Offset(, -1)
i = i + 1
Set c = .FindNext(c)
Loop While Not c Is Nothing And c.Address <> FirstAddress
End If
End With
Next
With Sh3
Set Users3 = Range(.Cells(5, 1), .Cells(Rows.Count, 1).End(xlUp))
End With

For Each cel In Users3
FirstAddress = ""
i = 1
With Users1
Set c = .Find(cel, LookIn:=xlValues)
If Not c Is Nothing Then
FirstAddress = c.Address
Do
cel.Offset(, i + 1) = c.Offset(, -1)
cel.Offset(, i + 2) = c.Offset(, 1)
i = i + 2
Set c = .FindNext(c)
Loop While Not c Is Nothing And c.Address <> FirstAddress
End If
End With
Next

End Sub

cc9083
05-22-2009, 09:10 PM
Hi mdmackillop. Thanks for the reply. When I run macro4 these were the actions done.
1) The data in Sheet 2 & 3 were automatically shifted to the top row creating empty rows below them. The shifted data are in figures instead of formulas.
2) Further data inserted in Sheet 1 and run with macro4 causes duplicates to the last row.

Basically this is what I need the VBA to do.

1) There shall be only 2 buttons in Sheet 1; Insert Row and Delete Row which are readily available. The insert button creates rows for data in Column A, B & C and the delete button performs otherwise. The insert button creates rows in all 3 worksheets and I would like it to create row only to Sheet 1.
2) When data is inserted in Column A, B & C of Sheet 1, the VBA will analyse for duplicate entries in Column B and when a duplicate entry is detected the VBA will not perform anything as the formulas in Sheet 2 & Sheet 3 will take care of it. However, in the event that a unique (non-duplicate) entry is detected, the VBA should create a new row at the top of Sheet 2 & Sheet 3 to accommodate for the new data. These new rows must be equipped with the formulas as per rows before them in order to calculate the data.

I hope my explanation is clearly understood and are possible to be done.

mdmackillop
05-23-2009, 12:21 PM
Simplest way is to add a hidden row containing the formula and using FillDown to populate the cells.

cc9083
05-23-2009, 08:39 PM
Wow! Amazing! I'm learning new stuffs here everyday. Thank you mdmackillop. You're a great man. :friends:

cc9083
05-23-2009, 10:47 PM
Removed

mdmackillop
05-24-2009, 02:49 AM
A selective Delete routine


Sub Macro2()
Dim WRN As Worksheet
Dim UR As Worksheet
Dim WVPU As Worksheet
Dim ToDelete As String
Dim sh As Worksheet
Dim Confirm As Long
Set WRN = Sheets(1)
Set UR = Sheets(2)
Set WVPU = Sheets(3)

ToDelete = WRN.Cells(ActiveCell.Row, 2)
If ToDelete <> "" Then
Confirm = MsgBox("This will delete" & vbCr & _
"Name: " & WRN.Cells(ActiveCell.Row, 2) & vbCr & _
"Job: " & WRN.Cells(ActiveCell.Row, 1), vbYesNo)
If Confirm = vbNo Then Exit Sub

If Application.CountIf(Columns(2), ToDelete) = 1 Then
If ToDelete <> "" Then
UR.Columns(1).Find(ToDelete, lookat:=xlWhole).EntireRow.Delete
WVPU.Columns(1).Find(ToDelete, lookat:=xlWhole).EntireRow.Delete
End If
End If
End If
ActiveCell.EntireRow.Delete
End Sub

cc9083
05-24-2009, 09:24 PM
Hi mdmackillop. Thanks again for the code. However, the delete code that you provide is not working. Maybe you can look into it again. Regards.

mdmackillop
05-25-2009, 12:33 AM
:dunno

cc9083
05-25-2009, 12:55 AM
Here is the spreadsheet for your reference. I've included your code under macro2 but when I click the button from the spreadsheet no action was done (row was not deleted). Did I do something wrong?

mdmackillop
05-25-2009, 01:25 AM
It works for me as intended. Have you tried following/stepping through the code?

cc9083
05-25-2009, 01:34 AM
I replace the old macro2 code with the your new macro2 code under Module1 as below. What is the new code supposed to do? You can edit my spreadsheet.



Sub Macro1()
Dim WRN As Worksheet
Set WRN = Sheets(1)

With WRN.Range("A5:D5")
.Insert Shift:=xlDown
.Offset(-1).Interior.ColorIndex = xlNone
End With

End Sub
Sub Macro2()
Dim WRN As Worksheet
Dim UR As Worksheet
Dim WVPU As Worksheet
Dim ToDelete As String
Dim sh As Worksheet
Dim Confirm As Long
Set WRN = Sheets(1)
Set UR = Sheets(2)
Set WVPU = Sheets(3)

ToDelete = WRN.Cells(ActiveCell.Row, 2)
If ToDelete <> "" Then
Confirm = MsgBox("This will delete" & vbCr & _
"Name: " & WRN.Cells(ActiveCell.Row, 2) & vbCr & _
"Job: " & WRN.Cells(ActiveCell.Row, 1), vbYesNo)
If Confirm = vbNo Then Exit Sub

If Application.CountIf(Columns(2), ToDelete) = 1 Then
If ToDelete <> "" Then
UR.Columns(1).Find(ToDelete, lookat:=xlWhole).EntireRow.Delete
WVPU.Columns(1).Find(ToDelete, lookat:=xlWhole).EntireRow.Delete
End If
End If
End If
ActiveCell.EntireRow.Delete
End Sub

cc9083
05-25-2009, 02:32 AM
Played around with it and finally figured out that you need to click on the cell that you want to delete before pressing the button. Thought that it will automatically delete the first top row :doh: but anyway it's a good idea to have some flexibility. :thumb Thanks again.

cc9083
05-25-2009, 05:44 AM
Just found out minutes ago that the codes doesn’t work when copying and pasting data into Column A, B & C in Sheet 1. There are no updates on both Sheet 2 & Sheet 3.

Usually I’ll receive tables of data from my colleagues and then I’ll just filter the data that I need and copy them into Sheet 1. When I need to enter say 50 rows of data each time I receive them, I’ll insert 50 empty rows with the button then paste the data accordingly. I’m happy with what we’ve achieved so far but it would be great if the codes accept “copy and paste” data.

On the other hand, it would be even greater if there is a dialog box that pops up requesting the number of rows to be inserted instead of adding one row at a time. A delete rows that works in mass will also be great. Regards.

mdmackillop
05-25-2009, 05:49 AM
Please post as a new question.