엑셀 VBA #127 / Vlookup시리즈3_배열+Dictionary활용 [VBA]

Sub Vlookup기능실현_New_Scripting_Dictionary_배열231228()
      
      Dim dict As New Scripting.Dictionary
      Dim rngS, rngF
      Dim i As Long
      Dim arr()
      
      rngS = Sheet1.Range("a2", Sheet1.Cells(Rows.Count, "b").End(3)) 'rngS배열방 지정
      rngF = Sheet2.Range("a2", Sheet2.Cells(Rows.Count, "a").End(3)) 'rngT배열방 지정
      
      For i = 1 To UBound(rngS, 1)
            If dict.Exists(rngS(i, 1)) Then
            Else
                  dict.Add rngS(i, 1), rngS(i, 2)
                  'rngS(i,1)은 Key값, rngS(i,2)는 Item값임!!!!!
                  'cells(i,1)..cells(i,2)가 아님에 주의
            End If
      Next

      ReDim arr(1 To UBound(rngF, 1), 1 To 1)
      For i = 1 To UBound(rngF, 1)
            If dict.Exists(rngF(i, 1)) Then
                  arr(i, 1) = dict(rngF(i, 1))
                  ' "rngF(i,1)"은 Key값이고, 
                  "dict(rngF(i,1))"은 그 Key값에 해당하는 Item의 값임!!!!!!!
            Else
            End If
      Next
      
      Sheet2.Range("e2").Resize(UBound(arr, 1), 1) = arr

End Sub

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



https://www.youtube.com/watch?v=I4iyh9tF5kc&list=PLfxvqpVCYZ8e0qlyc_FU46neoWjO7yTWj&index=129
ㅁㅁ

Dictionary방식( Late Binding & Early Binding)

1. Late Binding : 'MicroSoft Scripting Runtime'체크확인 불필요

Sub usedictionary()

Dim rDatas As Range
Dim oDic As Object                          '일단 범용 Object로 선언 후
Dim rRow As Range
Dim sKey As String
Dim iItem As Integer
Dim ix As Integer

Set rDatas = Worksheets("Sales").Range("A1").CurrentRegion
Set rDatas = rDatas.Offset(1).Resize(rDatas.Rows.Count - 1)

Set oDic = CreateObject("scripting.Dictionary")    'Dictionary로 지정한다.

For Each rRow In rDatas.Rows
    sKey = rRow.Cells(3) 
    iItem = rRow.Cells(4)
    If Not oDic.exists(sKey) Then
        oDic.Add sKey, iItem
    Else
        oDic(sKey) = oDic(sKey) + iItem
    End If
Next

With Range("H1")
    For ix = 0 To oDic.Count - 1
        .Offset(ix) = oDic.keys()(ix)                ()() 반드시 지켜야 한다.
        .Offset(ix, 1) = oDic.items()(ix)           ()() 반드시 지켜야 한다.
    Next
End With
End Sub

https://www.youtube.com/watch?v=wKbOZpZ9vVQ

2. Early Binding : 'MicroSoft Scripting Runtime'체크확인 필요

Sub usedictionary2()

Dim rDatas As Range
Dim oDic As Scripting.Dictionary

Dim rRow As Range
Dim sKey As String
Dim iItem As Integer

Dim ix As Integer

Set rDatas = Worksheets("Sales").Range("A1").CurrentRegion
Set rDatas = rDatas.Offset(1).Resize(rDatas.Rows.Count - 1)

Set oDic = New Dictionary

For Each rRow In rDatas.Rows
    sKey = rRow.Cells(3)
    iItem = rRow.Cells(4)
      If Not oDic.exists(sKey) Then
        oDic.Add sKey, iItem
    Else
        oDic(sKey) = oDic(sKey) + iItem
    End If
Next

With Range("H1")
    For ix = 0 To oDic.Count - 1
        .Offset(ix) = oDic.keys(ix)             ()() or () 둘 중 하나 사용해도 된다.
        .Offset(ix, 1) = oDic.Items(ix)       ()() or () 둘 중 하나 사용해도 된다.
    Next
End With
End Sub

https://www.youtube.com/watch?v=aFKrdTGgUT8

https://raymond.tistory.com/2246

엑셀 VBA #118 / Dictionary 개체_기본 [VBA]

[엑셀이뭐니]매크로 기초 11강-Match 함수로 찾기(응용편)/ 중단모드 해제하기/ 엑셀 VBA 기초

Sub match함수응용()

Dim rok As Long
Dim endr As Long
Dim R As Range

On Error Resume Next

endr = Cells(Rows.Count, "A").End(xlUp).Row
Range(Cells(2, 1), Cells(endr, 1)).Select

For Each R In Selection
    a = R                     '상품명
    b = R.Offset(0, 1)        '색상
    c = R.Offset(0, 2)        '사이즈
    d = a & "/" & b & "/" & c
    
    
    rok = Application.Match(d, Sheets("sheet1").Columns("A"), 0)
    
    R.Offset(0, 3) = Sheets("sheet1").Cells(rok, 5)
    
    rok = 0                'rok값을 초기화

Next
End Sub

rok값을 초기화 이유

원피스 색상에는 '핑크'가 없으나 바로 전 값인 50을 불러 와 버림.

이를 위해 rok값을 초기화하는 것임

https://www.youtube.com/watch?v=7XCt64TAo0M
ㅁㅁㅁ

엑셀 VBA #126 / Vlookup시리즈2_배열 활용 [VBA]
Vlookup 함수같은 기능
   1. 파워쿼리
   2. 배열
   3. 배열 + Dictionary

Sub VlookupVBA_1()   '배열로 Vlookup기능실현

Dim rngS As Variant     '워크시트의 셀범위를 배열로 집어 넣을 땐 항상 Variant임
Dim rngF As Variant      '           "
Dim arr()


Application.ScreenUpdating = False
Sheet2.Range("E2:E" & Sheet2.Range("A2").End(xlDown).Row).Clear

rngS = Sheet1.Range("A2", Sheet1.Cells(Rows.Count, "B").End(3))

셀 범위'Sheet1.Range("A2", Sheet1.Cells(Rows.Count, "B").End(3))'를 rngS방에 넣기
rngF = Sheet2.Range("A2", Sheet2.Cells(Rows.Count, "A").End(3))
셀 범위'Sheet2.Range("A2", Sheet2.Cells(Rows.Count, "A").End(3))'를 rngS방에 넣기

ReDim arr(1 To UBound(rngF, 1), 1 To 1) '?????
For i = 1 To UBound(rngF, 1)        'UBound(rngF,1) : rngF의 1차원영역의 최대값
    For j = 1 To UBound(rngS, 1)   'UBound(rngS,1) : rngS의 1차원영역의 최대값
        'Sheet2.Cells(i, "E") = rngS(j, 2) '본 코드사용시 속도저하(배열코드가 아니라 워크시트 코드?이므로)
                If rngF(i, 1) = rngS(j, 1) Then
                        arr(i, 1) = rngS(j, 2)
                        Exit For '영상에서 이 코드는 빼먹었습니다.    넣어야 합니다.

                                       '1:1로 매칭되므로 값을 찾았으면 안쪽 for문을 빠져나와야지

                                       '그렇지 않으면 끝까지 루프를 돌므로 시간이 더 소요가 됩니다.
                End If
    Next
Next

Sheet2.Range("E2").Resize(UBound(arr, 1), 1) = arr
Application.ScreenUpdating = True

End Sub

https://www.youtube.com/watch?v=QM-o-95daIc&list=PLfxvqpVCYZ8e0qlyc_FU46neoWjO7yTWj&index=128

엑셀 VBA #29 / VBA함수(split) [VBA]

엑셀 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 #118 / Dictionary 개체_기본 [VBA]

[New Dictionary]
Dim dict As Oject
Set dict = CreateObject("scripting.dictionary")
위 두 문장으로 된 구문( Late Binding이라 함)을

아래 하나의 문장으로 된 구문( Early Binding이라 함)으로 할 수 있다.

Dim dict As New Scripting.Dictionary



1.구조 
Dictionary이름명. Add  Key  Item


2. 예시
dict.Add "사과",111
dict.Add "바나나",222
dict.Add "딸기",333

3. For ~ Next문에 적용

3.1. 기본
Dim dict As New Scripting.Dictionary
Dim i As Long

dict.Add "사과", 111
dict.Add "바나나", 222
dict.Add "딸기", 333

For i = 0 To 2
    Cells(i + 1, 1) = dict.Items(i)
Next

위 구문의 문제점은 Item 갯수가 아주 많은 경우에는 처리속도가 느려진다는 것이다..

그래서 Key  및 Item값을 워크시트에 한꺼번 뿌려줄 필요가 있다.

이것을 할 수 있는 방법이 '배열'이다.

3.1. 동적배열

Dim dict As New Scripting.Dictionary
Dim i As Long
Dim arr() As Variant    '동적배열 적용. arr()의 값 유형을 모르니 Variant로 한다.

dict.Add "사과", 111
dict.Add "바나나", 222
dict.Add "딸기", 333

For i = 0 To 2
    'Cells(i + 1, 1) = dict.Items(i)
    ReDim Preserve arr(i)   ' 동적배열 적용문으로 동적배열의 사이즈를 i값으로 재선언
    arr(i) = dict.Items(i)        'item(i)값을 arr방에 집어넣기!!!!
Next

이제는 arr방에 들어온 item(i)값을 시트에 뿌려보자

......

   arr(i) = dict.Items(i)
Next

range("A1:A3") =arr

메모리 상에서는 arr은 아래 그림처럼 가로로 담겨져 있다.

이를 A1:A3로 올바르게 뿌려지기 위해서는 Transpose함수를 아래처럼 적용해야 한다.

range("A1:A3") =Application.transpose(arr)

3.1.1. UBound & LBound

For~Next문에서 i의 마지막 값을 프로그램이 자동으로 지정할 수 있도록 해야한다. 하드코딩하는 방법을 바람직하지 않다.프로그램이 알아서 값을 지정할 수 있도록 하는 변수에는 UBound와 LBound가 있다.

For i = 0 To 2

For i = 0 To UBound(dict.Items)   

4. 최종 코드

Sub Pdictionary()

Dim dict As New Scripting.Dictionary
Dim i As Long
Dim arr() As Variant

dict.Add "사과", 111
dict.Add "바나나", 222
dict.Add "딸기", 333

For i = 0 To UBound(dict.Items)
    'Cells(i + 1, 1) = dict.Items(i)
    ReDim Preserve arr(i)
    arr(i) = dict.Items(i)
Next

Range("A1:A3") = Application.Transpose(arr)
 
End Sub

VBA - Dictionary(Late vs Early Binding) by 우노사설

https://www.youtube.com/watch?v=1yBE6MGkIA4&list=PLfxvqpVCYZ8e0qlyc_FU46neoWjO7yTWj&index=120

엑셀 VBA #88 / 시트통합_VBA필수 [VBA]

Sub MergeData_By_For_Next()
      Dim i As Long
      
      Application.ScreenUpdating = False
      
      Sheet1.Cells.Clear
      
      For i = 2 To 4
      'sheet2번부터 4번까지(1월~3월시트)//// 4를 'Worksheets.Count'로 하는 게 High Class
            Sheets(i).Range("a1").CurrentRegion.Copy _
            Sheet1.Cells(Rows.Count, "a").End(xlUp).Offset(1)
            '~~~~~~End(xlUp).Offset(1) => ~~~~~End(3)(2)
      Next
      
      Application.ScreenUpdating = True
End Sub

Sub MergeData_By_For_Each_Next()

      Dim sh As Worksheet
      Dim i As Long
      
      Application.ScreenUpdating = False
      
      Sheet1.Cells.Clear
      
      i = 2
      For Each sh In ThisWorkbook.Worksheets
            'if sh.name<>activesheet.name then
            If sh.Name <> Sheet1.Name Then   
            'If sh<>Sheet1 Then하면 에러인데...왜?
                  Sheets(i).Range("a1").CurrentRegion.Copy _
                  Sheet1.Cells(Rows.Count, "a").End(xlUp).Offset(1)
                  i = i + 1
            End If
      Next

      Application.ScreenUpdating = True
      
End Sub

Sub MergeData_By_Do_Loop()

      Dim cnt As Long, i As Long
      
      Application.ScreenUpdating = False
      
      Sheet1.Cells.Clear
      
      cnt = Worksheets.Count
      
      i = 2
      
      Do While i <= cnt
        Sheets(i).Range("a1").CurrentRegion.Copy _
        Sheet1.Cells(Rows.Count, "a").End(xlUp).Offset(1)
        i = i + 1
      Loop
      Application.ScreenUpdating = True
End Sub

Sub MergeData_By_For_Next실무형()
      Dim i As Long
      Dim rng As Range
      
      Application.ScreenUpdating = False
      
      Sheet1.Cells.Clear
      
      Sheet1.Range("a1:f1") = Array("월", "필드1", "필드2", "필드3", "필드4", "필드5")
      For i = 2 To Worksheets.Count
            Sheets(i).Range("a1").CurrentRegion.Copy _
            Sheet1.Cells(Rows.Count, "B").End(xlUp).Offset(1)
            
            Set rng = Sheet1.Range("a1").CurrentRegion
            rng.SpecialCells(xlCellTypeBlanks) = Sheets(i).Name
      Next
      Application.ScreenUpdating = True
End Sub

https://www.youtube.com/watch?v=lo7x3cG7rLI&list=PLfxvqpVCYZ8e0qlyc_FU46neoWjO7yTWj&index=89

엑셀 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

ㅁㅁㅁ