Find duplicates and Transpose in Excel VBA

[coolkiran]

Second post of the day

I found this post as tricky. so i need some assistance.

I have 2 columns, first column is bill no and second column is doc no.

So, i have multiple doc no with single bill no.

Now, I need all unique bill in one by one row and doc no in column by column

I have attached sample worksheet, because i am not good to explain it, is good to show in excel.

 

[Luke M]

If your numbers are numeric, you could use a PivotTable to do the work.



PT will re-arrange to horizontal (note that Doc# is a column field AND data field). Then I copied from PT, pasted as values, and deleted blanks to shift everything back to the left.

 

[Syedali]

Second post of the day

I found this post as tricky. so i need some assistance.

I have 2 columns, first column is bill no and second column is doc no.

So, i have multiple doc no with single bill no.

Now, I need all unique bill in one by one row and doc no in column by column

I have attached sample worksheet, because i am not good to explain it, is good to show in excel.

Hi,

PFA....

 

[coolkiran]

If your numbers are numeric, you could use a PivotTable to do the work.

View attachment 45566

PT will re-arrange to horizontal (note that Doc# is a column field AND data field). Then I copied from PT, pasted as values, and deleted blanks to shift everything back to the left.

Its good idea, i will try it.

 

[coolkiran]

Is there any way to do it in Excel VBA or formula's (I can make them to run using macro).

Actually i need to run this process once i clicked button. so pivot will not work.

Any other suggestion .

 

[Luke M]

Actually, I think a PivotTable would be necessary if you do with macro. For the macro, record yourself doing

1. PivotTable refresh
2. PivotTable range copy, paste as values
3. Remove blanks

Then you should be able to edit the recorded code to make it generic enough to handle things as your data grows.

 

[Kenneth Hobson]

If you preset your PivotTable, a maco can be used. Since I don't use PT's much, here is one approach. There are many other ways to do it.

'Run with Input sheet active.  Set r1 to suit.
Sub Main()
  Dim r0 As Range, r1 As Range, r2 As Range, r As Range
  Dim c As Range, ws0 As Worksheet, ws As Worksheet, a, b, v
  On Error GoTo TheEnd
  Application.Calculation = xlCalculationManual
  Application.ScreenUpdating = False
  Application.EnableEvents = False
  'Set first cell range with uniques, the column heading cell.
  'Set to suit.
  Set r0 = [C3] '<<<<<<<-------CHANGE THIS?
  Set r1 = r0.Offset(1)
  'Input sheet must be the activesheet.
  Set ws0 = ActiveSheet
  'Set range of the 2 input columns
  Set r = Range(r1, Cells(Rows.Count, r1.Row).End(xlUp))

  'Assign unique names to array.
  Set r1 = Intersect(Columns(r1.Column), r)
  a = r1
  a = UniqueArrayByDict(a)
  'Uncomment to sort uniques.
  'a = advArrayListSort(a)
  'Create an output worksheet
  Set ws = Worksheets.Add(after:=Worksheets(Worksheets.Count))
  'Rename output sheet
  ws.Name = "Output"
  'Format output column cells
  With ws
    r0.Copy .[a1]
    r1(1).Copy
    .[a2].Resize(UBound(a) + 1).PasteSpecial xlPasteFormats
     .[a2].Resize(UBound(a) + 1).Value = WorksheetFunction.Transpose(a)
  End With
  'Filter Input sheet for each unique column value.
  Set r = r.Offset(-1).Resize(r.Rows.Count + 1)
  Set c = ws.[b2] 'First cell in column 2 of output
  For Each v In a
    'Filter Input sheet for each unique column value.
    r.AutoFilter 1, v
   
    'Set column 2 visible range, less title cell.
    Set r2 = r.Offset(1)
    Set r2 = Intersect(r2, r.Columns(2).SpecialCells(xlCellTypeVisible))
    b = RangeTo1dArray(r2)
   
    'Uncomment next line if transposed data should be sorted.
    'b = advArrayListSort(b)
   
    c.Resize(, UBound(b) + 1).Value = b  'WorksheetFunction.Transpose(b)
    Set c = c.Offset(1)
  Next v
  ws.UsedRange.EntireColumn.AutoFit 'Resize Output columns
  r.AutoFilter  'Turn Autofilter off.
TheEnd:
  Application.CutCopyMode = True
  Application.Calculation = xlCalculationAutomatic
  Application.ScreenUpdating = True
  Application.EnableEvents = True
End Sub

Since I use these so often, I put them in another Module.

 'https://msdn.microsoft.com/en-us/library/system.collections.arraylist(v=vs.110).aspx
Function advArrayListSort(sn As Variant, Optional tfAscending1 As Boolean = True, _
    Optional tfAscending2 As Boolean = True, _
    Optional tfNumbersFirst As Boolean = True) As Variant
     
    Dim i As Long, c1 As Object, c2 As Object
    Dim a1() As Variant, a2() As Variant, a() As Variant
     
    Set c1 = CreateObject("System.Collections.ArrayList")
    Set c2 = CreateObject("System.Collections.ArrayList")
     
    For i = LBound(sn) To UBound(sn)
        If IsNumeric(sn(i)) = True Then
            c1.Add sn(i)
        Else
            c2.Add sn(i)
        End If
    Next i
     
    c1.Sort 'Sort ascendending
    c2.Sort 'Sort ascending
     
    If tfAscending1 = False Then c1.Reverse 'Sort and then Reverse to sort descending
    If tfAscending2 = False Then c2.Reverse 'Sort and then Reverse to sort descending
     
    a1() = c1.Toarray()
    a2() = c2.Toarray()
     
    If tfNumbersFirst = True Then
        a() = a1()
        For i = 1 To c2.Count
            ReDim Preserve a(UBound(a) + 1)
            a(UBound(a)) = a2(i - 1)
        Next i
    Else
        a() = a2()
        For i = 1 To c1.Count
            ReDim Preserve a(UBound(a) + 1)
            a(UBound(a)) = a1(i - 1)
        Next i
    End If
     
    advArrayListSort = a()
End Function

Function RangeTo1dArray(aRange As Range) As Variant
  Dim a() As Variant, c As Range, i As Long
  ReDim a(0 To aRange.Cells.Count - 1)
  i = i - 1
  For Each c In aRange
    i = i + 1
    a(i) = c
  Next c
  RangeTo1dArray = a()
End Function

' http://www.excelforum.com/excel-programming-vba-macros/819998-filter-and-sort-scripting-dictionary.html
'Early Binding method requires Reference: MicroSoft Scripting Runtime, scrrun.dll
Function UniqueArrayByDict(Array1d As Variant, Optional compareMethod As Integer = 0) As Variant
  Dim dic As Object 'Late Binding method - Requires no Reference
  Set dic = CreateObject("Scripting.Dictionary")  'Late or Early Binding method
  'Dim dic As Dictionary     'Early Binding method
  'Set dic = New Dictionary  'Early Binding Method
  Dim e As Variant
  dic.CompareMode = compareMethod
  'BinaryCompare=0
  'TextCompare=1
  'DatabaseCompare=2
  For Each e In Array1d
    If Not dic.Exists(e) Then dic.Add e, Nothing
  Next e
  UniqueArrayByDict = dic.Keys
End Function

 

[shrivallabha]

Here's dictionary based approach.

Public Sub DataReArrange()
Dim rng As Range
Dim oDict As Object
Set oDict = CreateObject("Scripting.Dictionary")
'\\ Load info in dictionary
For Each rng In Range("C4:C" & Range("C" & Rows.Count).End(xlUp).Row)
    If oDict.Exists(rng.Value) Then
        oDict.Item(rng.Value) = oDict.Item(rng.Value) & ";" & rng.Offset(0, 1).Value
    Else
        oDict.Add rng.Value, rng.Offset(0, 1).Value
    End If
Next
Dim rngDst As Range
Dim dKey
Dim lCnt As Long
'\\ ReArrange Data as needed
Set rngDst = Range("H10")
rngDst.CurrentRegion.Clear
lCnt = 0
For Each dKey In oDict.Keys
    rngDst.Offset(lCnt, 0).Value = dKey
    rngDst.Offset(lCnt, 1).Resize(1, UBound(Split(oDict.Item(dKey), ";")) + 1).Value = Split(oDict.Item(dKey), ";")
    lCnt = lCnt + 1
Next
Set oDict = Nothing
End Sub