Generate Details with Cell References!

Zshan

New member
Joined
Apr 28, 2020
Messages
31
Reaction score
0
Points
0
Excel Version(s)
Excel10
HI,

IS It possible with Excel VBA to generate details with cell refernces if an Entire Row is repeated or any cell value is repeated!

Actually its very difficult when data sheet has hundreds of rows if anyone could suggest any macro it would be really helpful.

Here the Workbook named "NEW" has more details,

Thanks!
 

Attachments

  • NEW.xlsm
    9.8 KB · Views: 14
No reply yet!

Any suggestions would be helpful!
 
Try this macro:

Code:
Option Explicit

Sub TestMacro()
    Dim c As Range
    Dim r As Range
    Dim t As Range
    Dim w As Worksheet
    Dim lngR As Long
    Dim strA As String
    
    Set t = Worksheets("REPEATS").UsedRange
    
    Set w = Worksheets("DETAILS")
    w.Cells.ClearContents
    w.Range("A1").Value = "DETAILS"
    
    'check rows
    w.Range("A3").Value = "ROW REPEATS"
    lngR = 4
    For Each r In t.Rows
        If Application.CountA(r) = 0 Then GoTo NextRow
        For Each c In r.Cells
            If Application.CountIf(c.EntireColumn, c.Value) = 1 Then GoTo NextRow
        Next c
        w.Cells(lngR, "A").Value = "Row " & r.Row
        r.Copy w.Cells(lngR, "B")
        lngR = lngR + 1
NextRow:
    Next r
    
    
    'check Cells
    lngR = lngR + 2
    w.Range("A" & lngR).Value = "CELL REPEATS"
    lngR = lngR + 1
    w.Range("A" & lngR).Value = "VALUE"
    w.Range("B" & lngR).Value = "ADDRESSES"
    lngR = lngR + 1


    For Each c In t.Cells
        If c.Value = "" Or Application.CountIf(t, c.Value) = 1 Or Application.CountIf(w.Range("A:A"), c.Value) = 1 Then GoTo NextCell
        strA = c.Address(False, False)
        w.Cells(lngR, "A").Value = c.Value
        w.Cells(lngR, "B").Value = strA
        
        Set r = t.Cells.Find(c.Value, c, xlValues, xlWhole)
        While r.Address(False, False) <> strA
            w.Cells(lngR, w.Columns.Count).End(xlToLeft)(1, 2).Value = r.Address(False, False)
            Set r = t.FindNext(r)
        Wend
        lngR = lngR + 1
NextCell:
    Next c




End Sub
 
I realized that my macro would flag a row as repeated if all the values were repeated, even if they were not in the same row. And I cannot edit my last post (though I can edit this post), so here is the fixed code:

Code:
Option Explicit

Sub TestMacro()
    Dim c As Range
    Dim m As Range
    Dim r As Range
    Dim t As Range
    Dim w As Worksheet
    Dim lngR As Long
    Dim strA As String
    Dim j As Integer
    
    Set t = ThisWorkbook.Worksheets("REPEATS").UsedRange
    
    Set w = ThisWorkbook.Worksheets("DETAILS")
    w.Cells.ClearContents
    w.Range("A1").Value = "DETAILS"
    
    'check rows
    w.Range("A3").Value = "ROW REPEATS"
    lngR = 4
    For Each c In t.Columns(1).Cells
        If c = "" Then GoTo NextRow
            If Application.CountIf(c.Offset(1, 0).Resize(t.Rows.Count, 1), c.Value) = 0 Then
                GoTo NextRow
            Else
                Set m = c.Offset(0, 0).Resize(t.Rows.Count, 1).Find(c.Value, c)
                strA = m.Row
                While m.Address <> c.Address
                    For j = 1 To t.Columns.Count - 1
                        If m.Offset(0, j).Value <> c.Offset(0, j).Value Then GoTo NextRow
                    Next j
                    Set m = c.EntireColumn.FindNext(m)
                Wend
            End If
        w.Cells(lngR, "A").Value = "Row " & c.Row
        Intersect(t, c.EntireRow).Copy w.Cells(lngR, "B")
        lngR = lngR + 1
        w.Cells(lngR, "A").Value = "Row " & strA
        Intersect(t, t.Parent.Rows(strA)).Copy w.Cells(lngR, "B")
        lngR = lngR + 1
NextRow:
    Next c
    
    
    'check Cells
    lngR = lngR + 2
    w.Range("A" & lngR).Value = "CELL REPEATS"
    lngR = lngR + 1
    w.Range("A" & lngR).Value = "VALUE"
    w.Range("B" & lngR).Value = "ADDRESSES"
    lngR = lngR + 1


    For Each c In t.Cells
        If c.Value = "" Or Application.CountIf(t, c.Value) = 1 Or Application.CountIf(w.Range("A:A"), c.Value) = 1 Then GoTo NextCell
        strA = c.Address(False, False)
        w.Cells(lngR, "A").Value = c.Value
        w.Cells(lngR, "B").Value = strA
        
        Set r = t.Cells.Find(c.Value, c, xlValues, xlWhole)
        While r.Address(False, False) <> strA
            w.Cells(lngR, w.Columns.Count).End(xlToLeft)(1, 2).Value = r.Address(False, False)
            Set r = t.FindNext(r)
        Wend
        lngR = lngR + 1
NextCell:
    Next c


End Sub
 
Hi
Thanks for the help!
I can't thank you enough you saved me from a headache!
 
You're very welcome - it was a fun brain teaser!
 
Back
Top