Posts by jindon

Sub test()
    Dim r As Range, LastR As Range, dic As Object
    Dim temp As String, w, e, i As Long, flg As Boolean
    Set dic = CreateObject("Scripting.Dictionary")
    dic.CompareMode = 1
    With Sheets("sheet1").Columns(1).SpecialCells(2)
        For Each r In .Areas
            temp = GetCategory(r.Value)
            If Not dic.exists(temp) Then
                ReDim w(1 To 2)
            Else
                w = dic(temp)
                ReDim Preserve w(1 To UBound(w) + 2)
            End If
            Set w(UBound(w) - 1) = r
            Set w(UBound(w)) = r.Offset(, 3).CurrentRegion
            dic(temp) = w
        Next
    End With
    With Sheets("sheet2")
        For Each e In dic
            For i = 1 To UBound(dic(e)) Step 2
                Set LastR = .Range("a" & Rows.Count).End(xlUp)(2 + IIf(flg, 1, 0))
                flg = False
                With LastR
                    dic(e)(i).Copy .Resize(dic(e)(i + 1).Columns.Count)
                    dic(e)(i + 1).Copy
                    .Offset(, 1).PasteSpecial Transpose:=True
                End With
            Next
            flg = True
        Next
    End With
End Sub


Function GetCategory(txt As String) As String
    Dim x
    x = Split(txt)
    If (UBound(x) > 0) * (IsNumeric(x(UBound(x)))) Then
        ReDim Preserve x(UBound(x) - 1)
    End If
    GetCategory = Join(x)
End Function

Sub test()
    Dim a, e, i As Long, ii As Long, r As Range, dic As Object
    Set dic = CreateObject("Scripting.Dictionary")
    dic.CompareMode = 1
    For Each e In Array("ADM", "LRA")
        a = Sheets(e).Cells(1).CurrentRegion.Value
        For i = 2 To UBound(a, 1)
            If Not dic.exists(a(i, 1)) Then
                Set dic(a(i, 1)) = CreateObject("System.Collections.ArrayList")
            End If
            For ii = 3 To UBound(a, 2)
                If a(i, ii) <> "" Then
                    If dic(a(i, 1)).Contains(a(i, ii)) Then
                        dic(a(i, 1)).Remove a(i, ii)
                    Else
                        dic(a(i, 1)).Add a(i, ii)
                    End If
                End If
            Next
        Next
    Next
    With Sheets("Result").Cells(1).CurrentRegion
        .Offset(, 3).ClearContents
        For Each r In .Columns(1).Cells
            If dic.exists(r.Value) Then
                If dic(r.Value).Count Then
                    r(, 4).Resize(, dic(r.Value).Count).Value = dic(r.Value).ToArray
                End If
            End If
        Next
    End With
End Sub

Sub test()
    Dim a, i As Long, ii As Long, n As Long, myList, flg As Boolean
    With Cells(1).CurrentRegion
        a = .Value
        For i = 1 To UBound(a, 1)
            If Not IsArray(myList) Then
                ReDim myList(1 To 1)
            Else
                For ii = 1 To n
                    If a(i, 1) = myList(n) Then
                        flg = True: Exit For
                    End If
                Next
            End If
            If Not flg Then
                n = n + 1
                ReDim Preserve myList(1 To n)
                myList(n) = a(i, 1)
                For ii = 1 To UBound(a, 2)
                    a(n, ii) = a(i, ii)
                Next
            Else
                For ii = 1 To UBound(a, 2)
                    If InStr(1, ", " & a(n, ii) & ",", ", " & a(i, ii) & ",", 1) = 0 Then
                        a(n, ii) = a(n, ii) & ", " & a(i, ii)
                    End If
                Next
                flg = False
            End If
        Next
        .Offset(, .Columns.Count + 2).Resize(n).Value = a
    End With
End Sub

Sub test()
    Dim a, i As Long, ii As Long, n As Long, dic As Object
    Dim sDate As Date, eDate As Date, temp As Date, myTbl As ListObject
    Const myStyle As String = "TableStyleMedium9"
    Set dic = CreateObject("Scripting.Dictionary")
    With Sheets("sheet1").Cells(1).CurrentRegion
        sDate = Application.Min(.Columns("ay"))
        sDate = sDate - Day(sDate) + 1
        eDate = Application.Max(.Columns("ay"))
        eDate = eDate - Day(eDate) + 1
        a = .Value
    End With
    Do
        temp = DateAdd("m", n, sDate)
        Set dic(Format$(temp, "mmmm, yyyy")) = _
        CreateObject("System.Collections.ArrayList")
        n = n + 1
    Loop While temp < eDate
    For i = 2 To UBound(a, 1)
        If a(i, 51) <> "" Then
            a(i, 51) = Format$(a(i, 51), "mmmm, yyyy")
            dic(a(i, 51)).Add _
            Join(Array(a(i, 4), Format$(a(i, 51), "mm/dd/yyyy")), " - ")
        End If
    Next
    With Sheets("OutPut")
        .Cells.Delete
        With .Cells(1).Resize(, dic.Count)
            .Value = dic.keys
            For ii = 1 To .Columns.Count
                If dic(.Cells(1, ii).Value).Count > 0 Then
                    .Cells(2, ii).Resize(dic(.Cells(1, ii).Value).Count).Value = _
                    Application.Transpose(dic(.Cells(1, ii).Value).ToArray)
                End If
            Next
        End With
        With .Cells(1).CurrentRegion
            .Rows(1).Font.Size = 12
            Set myTbl = .Parent.ListObjects.Add(1, .Cells, , 1)
            myTbl.TableStyle = myStyle
            myTbl.ShowAutoFilter = False
            .RowHeight = 40.25
            .VerticalAlignment = xlTop
            .HorizontalAlignment = xlCenter
            .Columns.AutoFit
        End With
        .Select
    End With
End Sub