PDA

View Full Version : removing the double names by changing the current macro


hakunamatata
09-01-2012, 03:22 AM
Hello Everybody
I have a macro which compares the two worksheets when the comparison is found the give the results in the worksheet 3 . The problem is that if the Comparison criteria is repeated then it gives the names two time. The sample workbook is attached with this post.
PAB
09-01-2012, 03:06 PM
Hi hakunamatata,

Try this:

Option Explicit

Sub DeleteDups()
Dim x As Long
Dim LastRow As Long
With Application
.ScreenUpdating = False: .Calculation = xlCalculationManual: .DisplayAlerts = False
End With
LastRow = Range("D65536").End(xlUp).Row
For x = LastRow To 11 Step -1
If Application.WorksheetFunction.CountIf(Range("D11:D" & x), Range("D" & x).Text) > 1 Then
Range("D" & x).EntireRow.Delete
End If
Next x
With Application
.DisplayAlerts = True: .Calculation = xlCalculationAutomatic: .ScreenUpdating = True
End With
End Sub
I hope this helps!

Regards,
PAB
hakunamatata
09-02-2012, 03:25 AM
yes, Super. Thanks for your help
PAB
09-02-2012, 04:24 AM
Hi hakunamatata,

I just noticed that your initial code in your Workbook does NOT work.

Regards,
PAB
hakunamatata
09-02-2012, 05:28 AM
yes, i have made the cilly mistake in my first workbook. if you delete the "Name", "Future Value" and "Present Value" from both of the sheets then it will work.
PAB
09-02-2012, 06:17 AM
Hi hakunamatata,

If you use the following code you will NOT have to delete the "Name", "Future Value" and "Present Value" from both of the sheets.
It will also DELETE all the duplicates on Sheet(3).

Sub a()
With Application
.ScreenUpdating = False: .Calculation = xlCalculationManual: .DisplayAlerts = False
End With
LR1 = Sheets(1).Cells(Rows.Count, "C").End(xlUp).Row
LR2 = Sheets(2).Cells(Rows.Count, "C").End(xlUp).Row
LastRow = 10
For arow = 10 To LR1
aname = Sheets(1).Cells(arow, 3).Value
If aname <> prevname Then
prevname = aname
future = 0
present = 0
With Sheets(2).Range("C11:C" & LR2)
Set c = .Find(aname, LookIn:=xlValues, LookAt:=xlPart) 'Whole)
If Not c Is Nothing Then
firstAddress = c.Row
Do
Set c = .FindNext(c)
future = future + c.Offset(0, 1).Value
present = present + c.Offset(0, 2).Value
Loop While Not c Is Nothing And c.Row <> firstAddress
LastRow = LastRow + 1
Sheets(3).Cells(LastRow, 4).Value = c 'aname
Sheets(3).Cells(LastRow, 5).Value = future
Sheets(3).Cells(LastRow, 6).Value = present
For x = LastRow To 10 Step -1
If Application.WorksheetFunction.CountIf(Range("D11:D" & x), _
Range("D" & x).Text) > 1 Then
Range("D" & x).EntireRow.Delete
End If
Next x
End If
End With
End If
Next
With Application
.DisplayAlerts = True: .Calculation = xlCalculationAutomatic: .ScreenUpdating = True
End With
End Sub
I hope this helps!

Regards,
PAB
hakunamatata
09-02-2012, 06:46 AM
Yes this works thanks.
hakunamatata
09-02-2012, 06:58 AM
Hello Again,
Can you also please help me by changing the code which is attached with the workbook using if statement.
PAB
09-02-2012, 07:13 AM
Hi hakunamatata,

I have amended the code I posted at Today, 02:17 PM.
Please ignore it and use the new code above.
I amended it at Today, 02:50 PM and you answered the post at Today, 02:46 PM, 4 minutes before I posted the new version.

I will have a look at the Workbook.

Regards,
PAB
PAB
09-02-2012, 08:08 AM
Hi hakunamatata,

If the Present Value and Future Value are less than 50 and the Date shows "equal", then what do you want it to show instead of ID?

Regards,
PAB
hakunamatata
09-02-2012, 08:36 AM
Then nothing should be shown.
hakunamatata
09-02-2012, 09:24 AM
Hi PAB
Did you get my point?
PAB
09-02-2012, 09:41 AM
Hi hakunamatata,

Give this a try.

Sub Macro()
With Application
.ScreenUpdating = False: .Calculation = xlCalculationManual: .DisplayAlerts = False
End With
Set sht = Sheets("Balance")
With sht
lstRow = .Range("A" & .Rows.Count).End(xlUp).Row
o = 2
' Sheets("Report").Range("A2:D2").Value = .Range("G2:J2").Value
On Error Resume Next
Sheets("temp").Delete
Worksheets.Add(Sheets(1)).Name = "temp"
Sheets("temp").Range("A2:J2").Value = .Range("A2:J2").Value
Sheets("temp").Range("A2:A" & lstRow).Value = .Range("A2:A" & lstRow).Value
Sheets("temp").Range("G2:G" & lstRow).Value = .Range("G2:G" & lstRow).Value
Sheets("temp").Activate
Sheets("temp").Range("A2:A" & lstRow).RemoveDuplicates Columns:=1, Header:=xlYes
Sheets("temp").Range("G2:G" & lstRow).RemoveDuplicates Columns:=1, Header:=xlYes
lstRow2 = Sheets("temp").Range("A" & Sheets("temp").Rows.Count).End(xlUp).Row
lstRow3 = Sheets("temp").Range("G" & Sheets("temp").Rows.Count).End(xlUp).Row
For m = 2 To lstRow2
Sheets("temp").Range("B" & m).Value = Application.WorksheetFunction.SumIf(sht.Range("A:D"), _
Sheets("temp").Range("A" & m), sht.Range("B:B"))
Sheets("temp").Range("C" & m).Value = Application.WorksheetFunction.SumIf(sht.Range("A:D"), _
Sheets("temp").Range("A" & m), sht.Range("C:C"))
Sheets("temp").Range("D" & m).Value = Application.WorksheetFunction.SumIf(sht.Range("A:D"), _
Sheets("temp").Range("A" & m), sht.Range("D:D"))
Next
For m = 2 To lstRow3
Sheets("temp").Range("H" & m).Value = Application.WorksheetFunction.SumIf(sht.Range("G:J"), _
Sheets("temp").Range("G" & m), sht.Range("H:H"))
Sheets("temp").Range("I" & m).Value = Application.WorksheetFunction.SumIf(sht.Range("G:J"), _
Sheets("temp").Range("G" & m), sht.Range("I:I"))
Sheets("temp").Range("J" & m).Value = Application.WorksheetFunction.SumIf(sht.Range("G:J"), _
Sheets("temp").Range("G" & m), sht.Range("J:J"))
Next
With Sheets("temp")
For m = 2 To lstRow2 'In sheet temp Cell putting the unequal values to cell m=2
Set foundcell = .Range("G:G").Find(what:=.Cells(m, 1).Value)
If Not foundcell Is Nothing Then
If .Cells(m, 2).Value <> foundcell.Offset(0, 1).Value Or .Cells(m, 3).Value _
<> foundcell.Offset(0, 2).Value Or .Cells(m, 4).Value <> foundcell.Offset(0, 3).Value Then
.Cells(o, 13).Value = .Cells(m, 1).Value
.Cells(o, 14).Value = .Cells(m, 2).Value - foundcell.Offset(0, 1).Value
.Cells(o, 15).Value = .Cells(m, 3).Value - foundcell.Offset(0, 2).Value

If .Cells(m, 4).Value - foundcell.Offset(0, 3).Value <> 0 Then
.Cells(o, 16).Value = "Unequal"
Else
.Cells(o, 16).Value = "equal"
End If
o = o + 1
End If
End If
Next
Columns("M:P").Select
Selection.Copy
Sheets("Report").Select
Range("A15").Select
Sheets("temp").Select
Range("M2:P9").Select
Application.CutCopyMode = False
Selection.Copy
Sheets("Report").Select
ActiveSheet.Paste
End With
' Sheets("temp").Delete
With Sheets("Balance")
Range("B10").Value = Evaluate("IF(AND(Balance!A2:D11=Balance!G2:J11),""All are equal"",""All are NOT equal"")")
End With
End With
With Application
.DisplayAlerts = True: .Calculation = xlCalculationAutomatic: .ScreenUpdating = True
End With
End Sub

Regards,
PAB
hakunamatata
09-02-2012, 09:48 AM
Hello
Thanks for your code, Actually this id FFF6412 should not come in output because here Present value and Future Value are less than 50 and Date is equal.
PAB
09-02-2012, 09:56 AM
Hi hakunamatata,

I will have a look at that in a little while.
Did the "All are NOT equal" for the Sheet "Balance" work OK?
If they were ALL equal it would output "All are equal".

Regards,
PAB
hakunamatata
09-02-2012, 09:56 AM
Sorry,
I have edited my last post, please take a look at it again.
hakunamatata
09-02-2012, 10:00 AM
Hi hakunamatata,

I will have a look at that in a little while.
Did the "All are NOT equal" for the Sheet "Balance" work OK?
If they were ALL equal it would output "All are equal".

Regards,
PAB

Yess "All are NOT equal" and "All are equal" works perfect.:rotlaugh:
PAB
09-02-2012, 10:06 AM
Hi hakunamatata,

Give this a go!

Sub Macro()
With Application
.ScreenUpdating = False: .Calculation = xlCalculationManual: .DisplayAlerts = False
End With
Set sht = Sheets("Balance")
With sht
lstRow = .Range("A" & .Rows.Count).End(xlUp).Row
o = 2
' Sheets("Report").Range("A2:D2").Value = .Range("G2:J2").Value
On Error Resume Next
Sheets("temp").Delete
Worksheets.Add(Sheets(1)).Name = "temp"
Sheets("temp").Range("A2:J2").Value = .Range("A2:J2").Value
Sheets("temp").Range("A2:A" & lstRow).Value = .Range("A2:A" & lstRow).Value
Sheets("temp").Range("G2:G" & lstRow).Value = .Range("G2:G" & lstRow).Value
Sheets("temp").Activate
Sheets("temp").Range("A2:A" & lstRow).RemoveDuplicates Columns:=1, Header:=xlYes
Sheets("temp").Range("G2:G" & lstRow).RemoveDuplicates Columns:=1, Header:=xlYes
lstRow2 = Sheets("temp").Range("A" & Sheets("temp").Rows.Count).End(xlUp).Row
lstRow3 = Sheets("temp").Range("G" & Sheets("temp").Rows.Count).End(xlUp).Row
For m = 2 To lstRow2
Sheets("temp").Range("B" & m).Value = Application.WorksheetFunction.SumIf(sht.Range("A:D"), _
Sheets("temp").Range("A" & m), sht.Range("B:B"))
Sheets("temp").Range("C" & m).Value = Application.WorksheetFunction.SumIf(sht.Range("A:D"), _
Sheets("temp").Range("A" & m), sht.Range("C:C"))
Sheets("temp").Range("D" & m).Value = Application.WorksheetFunction.SumIf(sht.Range("A:D"), _
Sheets("temp").Range("A" & m), sht.Range("D:D"))
Next
For m = 2 To lstRow3
Sheets("temp").Range("H" & m).Value = Application.WorksheetFunction.SumIf(sht.Range("G:J"), _
Sheets("temp").Range("G" & m), sht.Range("H:H"))
Sheets("temp").Range("I" & m).Value = Application.WorksheetFunction.SumIf(sht.Range("G:J"), _
Sheets("temp").Range("G" & m), sht.Range("I:I"))
Sheets("temp").Range("J" & m).Value = Application.WorksheetFunction.SumIf(sht.Range("G:J"), _
Sheets("temp").Range("G" & m), sht.Range("J:J"))
Next
With Sheets("temp")
For m = 2 To lstRow2 'In sheet temp Cell putting the unequal values to cell m=2
Set foundcell = .Range("G:G").Find(what:=.Cells(m, 1).Value)
If Not foundcell Is Nothing Then
If .Cells(m, 2).Value <> foundcell.Offset(0, 1).Value Or .Cells(m, 3).Value _
<> foundcell.Offset(0, 2).Value Or .Cells(m, 4).Value <> foundcell.Offset(0, 3).Value Then
.Cells(o, 13).Value = .Cells(m, 1).Value
.Cells(o, 14).Value = .Cells(m, 2).Value - foundcell.Offset(0, 1).Value
.Cells(o, 15).Value = .Cells(m, 3).Value - foundcell.Offset(0, 2).Value

If .Cells(m, 4).Value - foundcell.Offset(0, 3).Value <> 0 Then
.Cells(o, 16).Value = "Unequal"
Else
.Cells(o, 16).Value = "equal"
End If
If .Cells(o, 14).Value < 50 And .Cells(o, 15).Value < 50 And .Cells(o, 16).Value = "equal" Then
.Cells(o, 13).Value = "": .Cells(o, 14).Value = "":
.Cells(o, 15).Value = "": .Cells(o, 16).Value = ""
End If
o = o + 1
End If
End If
Next
Columns("M:P").Select
Selection.Copy
Sheets("Report").Select
Range("A15").Select
Sheets("temp").Select
Range("M2:P9").Select
Application.CutCopyMode = False
Selection.Copy
Sheets("Report").Select
ActiveSheet.Paste
End With
Sheets("temp").Delete
With Sheets("Balance")
Range("B10").Value = Evaluate("IF(AND(Balance!A2:D11=Balance!G2:J11),""All are equal"",""All are NOT equal"")")
End With
End With
With Application
.DisplayAlerts = True: .Calculation = xlCalculationAutomatic: .ScreenUpdating = True
End With
End Sub
Regards,
PAB
hakunamatata
09-02-2012, 10:18 AM
Hello Again,
The last question regarding this macro, it gives spaces if the condition met about less then 50, isn't it possible to avoid the empty row here.
PAB
09-02-2012, 11:07 AM
Hi hakunamatata,

Here you go!

Sub Macro()
With Application
.ScreenUpdating = False: .Calculation = xlCalculationManual: .DisplayAlerts = False
End With
Set sht = Sheets("Balance")
With sht
lstRow = .Range("A" & .Rows.Count).End(xlUp).Row
o = 2
' Sheets("Report").Range("A2:D2").Value = .Range("G2:J2").Value
On Error Resume Next
Sheets("temp").Delete
Worksheets.Add(Sheets(1)).Name = "temp"
Sheets("temp").Range("A2:J2").Value = .Range("A2:J2").Value
Sheets("temp").Range("A2:A" & lstRow).Value = .Range("A2:A" & lstRow).Value
Sheets("temp").Range("G2:G" & lstRow).Value = .Range("G2:G" & lstRow).Value
Sheets("temp").Activate
Sheets("temp").Range("A2:A" & lstRow).RemoveDuplicates Columns:=1, Header:=xlYes
Sheets("temp").Range("G2:G" & lstRow).RemoveDuplicates Columns:=1, Header:=xlYes
lstRow2 = Sheets("temp").Range("A" & Sheets("temp").Rows.Count).End(xlUp).Row
lstRow3 = Sheets("temp").Range("G" & Sheets("temp").Rows.Count).End(xlUp).Row
For m = 2 To lstRow2
Sheets("temp").Range("B" & m).Value = Application.WorksheetFunction.SumIf(sht.Range("A:D"), _
Sheets("temp").Range("A" & m), sht.Range("B:B"))
Sheets("temp").Range("C" & m).Value = Application.WorksheetFunction.SumIf(sht.Range("A:D"), _
Sheets("temp").Range("A" & m), sht.Range("C:C"))
Sheets("temp").Range("D" & m).Value = Application.WorksheetFunction.SumIf(sht.Range("A:D"), _
Sheets("temp").Range("A" & m), sht.Range("D:D"))
Next
For m = 2 To lstRow3
Sheets("temp").Range("H" & m).Value = Application.WorksheetFunction.SumIf(sht.Range("G:J"), _
Sheets("temp").Range("G" & m), sht.Range("H:H"))
Sheets("temp").Range("I" & m).Value = Application.WorksheetFunction.SumIf(sht.Range("G:J"), _
Sheets("temp").Range("G" & m), sht.Range("I:I"))
Sheets("temp").Range("J" & m).Value = Application.WorksheetFunction.SumIf(sht.Range("G:J"), _
Sheets("temp").Range("G" & m), sht.Range("J:J"))
Next
With Sheets("temp")
For m = 2 To lstRow2 'In sheet temp Cell putting the unequal values to cell m=2
Set foundcell = .Range("G:G").Find(what:=.Cells(m, 1).Value)
If Not foundcell Is Nothing Then
If .Cells(m, 2).Value <> foundcell.Offset(0, 1).Value Or .Cells(m, 3).Value _
<> foundcell.Offset(0, 2).Value Or .Cells(m, 4).Value <> foundcell.Offset(0, 3).Value Then
.Cells(o, 13).Value = .Cells(m, 1).Value
.Cells(o, 14).Value = .Cells(m, 2).Value - foundcell.Offset(0, 1).Value
.Cells(o, 15).Value = .Cells(m, 3).Value - foundcell.Offset(0, 2).Value
If .Cells(m, 4).Value - foundcell.Offset(0, 3).Value <> 0 Then
.Cells(o, 16).Value = "Unequal"
Else
.Cells(o, 16).Value = "equal"
End If
If .Cells(o, 14).Value < 50 And .Cells(o, 15).Value < 50 And .Cells(o, 16).Value = "equal" Then
.Cells(o, 13).Value = "": .Cells(o, 14).Value = "":
.Cells(o, 15).Value = "": .Cells(o, 16).Value = ""
End If
Range("M2:P100").Select
Selection.SpecialCells(xlCellTypeBlanks).Delete Shift:=xlUp
o = o + 1
End If
End If
Next
Columns("M:P").Select
Selection.Copy
Sheets("Report").Select
Range("A15").Select
Sheets("temp").Select
Range("M2:P9").Select
Application.CutCopyMode = False
Selection.Copy
Sheets("Report").Select
ActiveSheet.Paste
End With
Sheets("temp").Delete
With Sheets("Balance")
Range("B10").Value = Evaluate("IF(AND(Balance!A2:D11=Balance!G2:J11),""All are equal"",""All are NOT equal"")")
End With
End With
With Application
.DisplayAlerts = True: .Calculation = xlCalculationAutomatic: .ScreenUpdating = True
End With
End Sub
Regards,
PAB
hakunamatata
09-02-2012, 11:11 AM
Thank you really very much. You have made my day.
PAB
09-02-2012, 01:08 PM
Hi hakunamatata,

This one is better suited for your Workbook growth.

Sub Macro()
With Application
.ScreenUpdating = False: .Calculation = xlCalculationManual: .DisplayAlerts = False
End With
Set sht = Sheets("Balance")
With sht
lstRow = .Range("A" & .Rows.Count).End(xlUp).Row
o = 2
' Sheets("Report").Range("A2:D2").Value = .Range("G2:J2").Value.
On Error Resume Next
Sheets("temp").Delete
Worksheets.Add(Sheets(1)).Name = "temp"
Sheets("temp").Range("A2:J2").Value = .Range("A2:J2").Value
Sheets("temp").Range("A2:A" & lstRow).Value = .Range("A2:A" & lstRow).Value
Sheets("temp").Range("G2:G" & lstRow).Value = .Range("G2:G" & lstRow).Value
Sheets("temp").Activate
Sheets("temp").Range("A2:A" & lstRow).RemoveDuplicates Columns:=1, Header:=xlYes
Sheets("temp").Range("G2:G" & lstRow).RemoveDuplicates Columns:=1, Header:=xlYes
lstRow2 = Sheets("temp").Range("A" & Sheets("temp").Rows.Count).End(xlUp).Row
lstRow3 = Sheets("temp").Range("G" & Sheets("temp").Rows.Count).End(xlUp).Row
For m = 2 To lstRow2
Sheets("temp").Range("B" & m).Value = Application.WorksheetFunction.SumIf(sht.Range("A:D"), _
Sheets("temp").Range("A" & m), sht.Range("B:B"))
Sheets("temp").Range("C" & m).Value = Application.WorksheetFunction.SumIf(sht.Range("A:D"), _
Sheets("temp").Range("A" & m), sht.Range("C:C"))
Sheets("temp").Range("D" & m).Value = Application.WorksheetFunction.SumIf(sht.Range("A:D"), _
Sheets("temp").Range("A" & m), sht.Range("D:D"))
Next
For m = 2 To lstRow3
Sheets("temp").Range("H" & m).Value = Application.WorksheetFunction.SumIf(sht.Range("G:J"), _
Sheets("temp").Range("G" & m), sht.Range("H:H"))
Sheets("temp").Range("I" & m).Value = Application.WorksheetFunction.SumIf(sht.Range("G:J"), _
Sheets("temp").Range("G" & m), sht.Range("I:I"))
Sheets("temp").Range("J" & m).Value = Application.WorksheetFunction.SumIf(sht.Range("G:J"), _
Sheets("temp").Range("G" & m), sht.Range("J:J"))
Next
With Sheets("temp")
For m = 2 To lstRow2 ' In sheet "temp" Cell putting the unequal values to cell M2.
Set foundcell = .Range("G:G").Find(what:=.Cells(m, 1).Value)
If Not foundcell Is Nothing Then
If .Cells(m, 2).Value <> foundcell.Offset(0, 1).Value Or .Cells(m, 3).Value _
<> foundcell.Offset(0, 2).Value Or .Cells(m, 4).Value _
<> foundcell.Offset(0, 3).Value Then
.Cells(o, 13).Value = .Cells(m, 1).Value
.Cells(o, 14).Value = .Cells(m, 2).Value - foundcell.Offset(0, 1).Value
.Cells(o, 15).Value = .Cells(m, 3).Value - foundcell.Offset(0, 2).Value
If .Cells(m, 4).Value - foundcell.Offset(0, 3).Value <> 0 Then
.Cells(o, 16).Value = "Unequal"
Else
.Cells(o, 16).Value = "equal"
End If
If .Cells(o, 14).Value < 50 And .Cells(o, 15).Value < 50 And _
.Cells(o, 16).Value = "equal" Then
.Cells(o, 13).Value = "": .Cells(o, 14).Value = "":
.Cells(o, 15).Value = "": .Cells(o, 16).Value = ""
End If
Range("M2", Range("P65536").End(xlUp)).SpecialCells(xlBlanks).Delete Shift:=xlUp
o = o + 1
End If
End If
Next
Columns("M:P").Select
Selection.Copy
Sheets("Report").Select
Range("A15").Select
Sheets("temp").Select
Range("M2:P9").Select
Application.CutCopyMode = False
Selection.Copy
Sheets("Report").Select
ActiveSheet.Paste
End With
Sheets("temp").Delete
With Sheets("Balance")
Range("B10").Value = _
Evaluate("IF(AND(Balance!A2:D1000=Balance!G2:J1000),""All are equal"",""All are NOT equal"")")
End With
End With
With Application
.DisplayAlerts = True: .Calculation = xlCalculationAutomatic: .ScreenUpdating = True
End With
End Sub
Regards,
PAB
snb
09-03-2012, 09:26 AM
@PAB

Avoid any 'select' or 'activate' in VBA.
snb
09-03-2012, 10:03 AM
Alternative:


Sub snb()
sn = Sheets("balance").Cells(1).CurrentRegion
sp = Sheets("balance").Cells(1, 7).CurrentRegion

For j = 2 To UBound(sn)
x = Application.Match(sn(j, 1), Application.Index(sp, 0, 1), 0)
sn(j, 4) = IIf(sn(j, 4) = sp(x, 4), "equal", "unequal")
sn(j, 2) = sn(j, 2) - sp(x, 2)
sn(j, 3) = sn(j, 3) - sp(x, 3)
If sn(j, 4) = "equal" And sn(j, 2) < 50 And sn(j, 3) < 50 Then sn(j, 1) = ""
Next

Sheets("report").Cells(30, 1).Resize(UBound(sn), UBound(sn, 2)) = sn
Sheets("report").Cells(30, 1).CurrentRegion.Columns(1).SpecialCells(4).EntireRow.Delete
End Sub
hakunamatata
09-05-2012, 09:56 AM
Hello snb
Thanks for your code, unfortunately i didn't understand your code, can you please put it in the Module in Post 22.
snb
09-06-2012, 12:41 AM
Read about every part in the code you do not understand in the helpfiles of the VBEditor.