Excel: If cells match use related value
Closed
stormy
-
Oct 22, 2011 at 01:06 PM
venkat1926 Posts 1863 Registration date Sunday June 14, 2009 Status Contributor Last seen August 7, 2021 - Oct 23, 2011 at 12:49 AM
venkat1926 Posts 1863 Registration date Sunday June 14, 2009 Status Contributor Last seen August 7, 2021 - Oct 23, 2011 at 12:49 AM
Related:
- Excel: If cells match use related value
- Excel marksheet - Guide
- Excel free download - Download - Spreadsheets
- Number to words in excel - Guide
- Kernel for excel - Download - Backup and recovery
- Excel date format dd.mm.yyyy - Guide
1 response
venkat1926
Posts
1863
Registration date
Sunday June 14, 2009
Status
Contributor
Last seen
August 7, 2021
811
Oct 23, 2011 at 12:49 AM
Oct 23, 2011 at 12:49 AM
suppose data is like this
HDNNG1 HDNNG2 HDNNG3
123 Open Apple
123 ------------ Orange
123 ------------ Banana
456 ------------ Pear
456 Closed Kiwi
456 ------------ Orange
789 ------------ Pear
789 ------------ Banana
789 ------------ Pear
dashes are blanks
try this macro "test"
HDNNG1 HDNNG2 HDNNG3
123 Open Apple
123 ------------ Orange
123 ------------ Banana
456 ------------ Pear
456 Closed Kiwi
456 ------------ Orange
789 ------------ Pear
789 ------------ Banana
789 ------------ Pear
dashes are blanks
try this macro "test"
Sub TEST()
Dim r As Range, auniq As Range, x As String, rfull As Range, cuniq As Range, filt As Range
With Worksheets("sheet1")
Set r = Range(.Range("A1"), .Range("A1").End(xlDown))
Set auniq = .Range("A1").End(xlDown).Offset(5, 0)
Set rfull = .Range("A1").CurrentRegion
r.AdvancedFilter xlFilterCopy, , auniq, True
Set auniq = Range(auniq.Offset(1, 0), auniq.End(xlDown))
For Each cuniq In auniq
rfull.AutoFilter field:=1, Criteria1:=cuniq.Value
Set filt = rfull.Offset(1, 0).Resize(Rows.Count - 1, Columns.Count).SpecialCells(xlCellTypeVisible).Columns("B:B")
On Error GoTo nextcuniq
x = WorksheetFunction.Match("*", filt, -1)
'MsgBox x
filt.FormulaArray = filt.Cells(x, 1)
rfull.AutoFilter
nextcuniq:
Next cuniq
rfull.AutoFilter
Range(.Range("a1").End(xlDown).Offset(1, 0), .Cells(Rows.Count, "A").End(xlUp)).EntireRow.Delete
End With
End Sub
Sub undo()
Worksheets("sheet1").Cells.Clear
Worksheets("sheet2").Cells.Copy Worksheets("sheet1").Range("A1")
End Sub
