엑셀 VBA #119 / Dictionary 개체_실무 [VBA]

Range("A1").CurrentRegion.Copy Range("D1")
Range("D1").CurrentRegion.RemoveDuplicates Array(1, 2), xlYes
'array(1,2) : 제거할 인수가 CurrnetRegion영역의 1열과, 2열!!!
'xlYest 영역에 머리글이 포함되어 있음

최종코딩

Sub Pdictionary()
    Dim dict As New Scripting.Dictionary
    Dim rngS As Range, c As Range
    Dim i As Long
    Dim s As Variant
    
    Application.ScreenUpdating = False
    
    Columns("D:I").Clear
    Range("A1").CurrentRegion.Copy Range("D1")
    Range("D1").CurrentRegion.RemoveDuplicates Array(1, 2), xlYes
    'array(1,2) : 제거할 인수가 CurrnetRegion영역의 1열과, 2열!!!
    'xlYest 영역에 머리글이 포함되어 있음
    
    Set rngS = Range("D2", Cells(Rows.Count, "D").End(xlUp))
    
    For Each c In rngS
        If dict.Exists(c.Value) Then
            dict(c.Value) = dict(c.Value) & "," & c.Offset(, 1)
        Else
            dict.Add c.Value, c.Offset(, 1)  '딕셔너리명.Add Key값,Item값
            'dict 딕셔너리에 c의 key값과,c에서 1열 떨어진(offset(,1)) item값을 넣어라
        End If
    Next
    
Set rngt = Range("G1")

For i = 0 To UBound(dict.Items)
    s = Split(dict.Items(i), ",")  '딕셔너리 각각의 item의 값이 ","로 분리된 값을 임의의 배열방 s에 저장한다.
    rngt.Offset(0, i) = dict.Keys(i)
    rngt.Offset(1, i).Resize(UBound(s) + 1, 1).Value = Application.Transpose(s)   
Next

Columns("C:E").Delete
 Application.ScreenUpdating = True
  
  Set dict = Nothing
  Set Rng = Nothing
  Set c = Nothing
  Set rngS = Nothing
  Set rngt = Nothing
End Sub

엑셀 VBA #65 / 질문 답변(데이터 취합) [VBA]    RemoveDuplicates (Array(1,2)

엑셀 VBA #47 / 중복데이터 처리_1 [VBA]- Removeduplicates. 고급필터. New Collection

https://www.youtube.com/watch?v=SrOrTwZuxXA&list=PLfxvqpVCYZ8e0qlyc_FU46neoWjO7yTWj&index=121

ㅇ

엑셀 VBA #65 / 질문 답변(데이터 취합) [VBA]

[하나의 통합문서에 있는 여러 시트들의 데이터들을
중복데이터 제거 후 '통합'시트에 하나로 취합하는 방법]

해결 방법
1. 엑셀 기능(RemoveDuplicates) 적용한 VBA코딩
2. New Collection활용 한 VBA코딩

1. 엑셀 기능(RemoveDuplicates) 적용한 VBA코딩

Sub 통합생성_고유항목만_1()

Dim shAll As Worksheet
Dim sh As Worksheet

Application.ScreenUpdating = False
Application.DisplayAlerts = False  '기존 통합시트 삭제시 '삭제하시겠습니까?'라는 메세지창 나오기 않게!
On Error Resume Next   '만약 기존 통합시트가 없는 경우에, 아래 코드 실행시 에레 발생하므로

                                         본 코드삽입하여 에레발생하면 그냥 넘어가라는 의미
    Sheets("통합").Delete
On Error GoTo 0

Worksheets.Add(after:=Sheets(Sheets.Count)).Name = "통합"
Set shAll = Sheets("통합")

For Each sh In ThisWorkbook.Worksheets
    If sh.Name <> ActiveSheet.Name Then '만약 시트 이름이 activesheet(현재활성화된 시트=통합)이름과 다르다면
        sh.Range("A1").CurrentRegion.Copy shAll.Cells(Rows.Count, "a").End(xlUp).Offset(1)
    End If
Next

shAll.Range("A2").CurrentRegion.RemoveDuplicates (Array(1, 2))

shAll.Rows(1).Delete

Application.DisplayAlerts = True
Application.ScreenUpdating = True

End Sub

2. New Collection활용 한 VBA코딩

Sub 통합생성_고유항목만_2()

Dim shAll As Worksheet
Dim sh As Worksheet

Application.ScreenUpdating = False
Application.DisplayAlerts = False 
On Error Resume Next 
    Sheets("통합").Delete
On Error GoTo 0

Worksheets.Add(after:=Sheets(Sheets.Count)).Name = "통합"
Set shAll = Sheets("통합")

For Each sh In ThisWorkbook.Worksheets
    If sh.Name <> ActiveSheet.Name Then
        sh.Range("A1").CurrentRegion.Copy shAll.Cells(Rows.Count, "a").End(xlUp).Offset(1)
    End If
Next

'----------------------------------------
'New Collection
'----------------------------------------
Dim rng As Range, c As Range
Dim pc As New Collection
Dim e As Variant
Dim i

Set rng = shAll.Range("A2", shAll.Cells(Rows.Count, "A").End(xlUp))

On Error Resume Next
For Each c In rng
    If Len(c) Then
        pc.Add Trim(c), CStr(Trim(c))
    End If
Next
On Error GoTo 0

For Each e In pc
    i = i + 1
    shAll.Cells(i, "d") = e
    shAll.Cells(i, "e") = rng.Find(e, , , xlWhole).Offset(, 1).Value
Next
shAll.Columns("a:c").Delete

Application.DisplayAlerts = True
Application.ScreenUpdating = True

End Sub

https://www.youtube.com/watch?v=Tp7qn6n_wVM&list=PLfxvqpVCYZ8e0qlyc_FU46neoWjO7yTWj&index=65

ㅁㅁㅁ

엑셀 VBA #47 / 중복데이터 처리_1 [VBA]

중복데이터 처리 방법
1. Removeduplicates

    영역.RemoveDuplicates 중복제거할 열표시, Header포함여부

    cf, 중복제거 기준 열이 2이상 일 경우??????

     영역. RemoveDuplicates (array(1,2,...)), Header포함여부
2. 고급필터
3. New Collection


1. Removeduplicaste
Sub 중복데이터_removeduplicate()

Dim rng As Range
Set rng = Range("A1", Cells(Rows.Count, "A").End(xlUp))

rng.Copy Range("D1")
Range("D1").CurrentRegion.RemoveDuplicates 1, xlYes     '영역에서 첫번째 열 기준을 중복제거

End Sub

2. 고급필터
Sub 중복데이터_고급필터()
Dim rng As Range
Set rng = Range("A1", Cells(Rows.Count, "A").End(xlUp))

rng.AdvancedFilter xlFilterInPlace, , , 1

'xlFilterInPlace : '현재 위치 필터' 적용 의미
rng.SpecialCells(xlCellTypeVisible).Copy Range("D1")
ActiveSheet.ShowAllData

End Sub

3. New Collection
Sub 중복데이터_New_Collection()

Dim rng As Range

Dim c As Range
Dim dc As New Collection  '고유목록만 모여질 변수로 받음
Dim i As Long

Set rng = Range("A1", Cells(Rows.Count, "A").End(xlUp))

'------------------------------------------------------
'고유목만 dc변수방에 모우기
'------------------------------------------------------
On Error Resume Next

For Each c In rng
    If Len(c) Then '만약 변수c에 값이 있으면  ' 'If Not nc Is Nothing Then'으로 해도 결과동일하네... 
        dc.Add Trim(c), CStr(Trim(c))
    End If
Next

'------------------------------------------------------
'고유목을 뿌리기
'------------------------------------------------------
For i = 1 To dc.Count
    Cells(i, "D") = dc(i)
Next

End Sub

https://www.youtube.com/watch?v=Zr2pd5ZMfDQ&list=PLfxvqpVCYZ8e0qlyc_FU46neoWjO7yTWj&index=47

엑셀 VBA #35 / 고급필터 [VBA]
VBA - 중복값 제거(New Collection)
엑셀 VBA #65 / 질문 답변(데이터 취합) [VBA]    RemoveDuplicates (Array(1,2)