엑셀 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 #50 / 중복데이터 처리_3 [VBA]

Sub 중복데이타삭제_단계1()

Dim rng As Range
Dim lR As Long, lC As Long
Dim i As Long, j As Long
Dim rngX As Range

Set rng = Range("A3", Cells(Rows.Count, "D").End(xlUp))

lR = Cells(Rows.Count, "A").End(xlUp).Row
lC = rng.Columns.Count

rng(1, lC + 1).Resize(rng.Rows.Count, 1) = "=A3&B3&C3&D3"

For i = 3 To lR - 1
    For j = i + 1 To lR
        If Cells(i, "E") = Cells(j, "E") Then
            If rngX Is Nothing Then
                Set rngX = Cells(j, "A").Resize(1, lC + 1)
            Else
                Set rngX = Union(rngX, Cells(j, "A").Resize(1, lC + 1))
            End If
        End If
    Next
Next

If rngX Is Nothing = 0 Then rngX.Delete
Columns("e") = ""

End Sub

https://www.youtube.com/watch?v=i1vBAAKTBhY&list=PLfxvqpVCYZ8e0qlyc_FU46neoWjO7yTWj&index=50

엑셀 VBA #40 / 행 삭제_개선1 [VBA] - Union

엑셀 VBA #08 / 셀 범위 선택하기_3 [VBA] - Union

엑셀 VBA #48 / 중복데이터 처리_2 [VBA] - 신규항목 추출

Dim ro As Range, rc As Range

Set ro = Range("A2", Range("A2").End(xlDown))
Set rc = Range("D2", Cells(Rows.Count, "D").End(xlUp))

For Each c In rc
    If Application.CountIf(ro, c) = 0 Then
        c.Resize(, 2).Copy Cells(Rows.Count, "A").End(xlUp).Offset(1) 

              ' end(xlup).offset(1) =end(3)(2)와 같음
    End If
Next

위 코드 중 'Application.CountIf(ro, c) = 0' 구문은 아래 그림 워크시트 Countif함수식을 참고하여 만든 구문임.

For Each c In rc
If Application.CountIf(ro, c) = 0 Then
1번 코드 : c.Resize(, 2).Copy Cells(Rows.Count, "A").End(xlUp).Offset(1) 을

2번 코드 : c.Resize(, 2).Copy Range("A12").Offset(1) 으로 대체하면 안될까.......안됨!!!!

2번 코드를 실행하면 값이 'J-1    44'만 보여짐.
이는 For Each~Next구문을 순환하면서 맨 먼저 나온 신규항목 값인 'E-1    22'이  

"Range("A12").OffSet(1)"에 의해 'J-1    44'을 대체됨

https://www.youtube.com/watch?v=0ZvPQ_TGcm8&list=PLfxvqpVCYZ8e0qlyc_FU46neoWjO7yTWj&index=48

엑셀 VBA #45 / Find메서드_변형3 [VBA]

Dim sh8 As Worksheet, sh7 As Worksheet
Dim rng As Range, cf As Range
Dim ad As String

Set sh8 = Sheets("2018")
Set sh7 = Sheets("2017")
Set rng = sh7.Range("B3", sh7.Cells(Rows.Count, "B").End(xlUp))

'Cells(Rows.Count,"B")만 쓰면 오류 발생가능성 있으므로, 시트명 sh7를 붙힐 것

For Each c In sh8.Range("B3", sh8.Cells(Rows.Count, "B").End(xlUp))
    Set cf = rng.Find(c, , , xlWhole)
    If Not cf Is Nothing Then
        ad = cf.Address
        Do
            c.Offset(, 2) = "○"
            Set ccf = rng.FindNext(cf)
        
        Loop Until cf.Address = ad
    End If

https://www.youtube.com/watch?v=hSXQKoyhXNE&list=PLfxvqpVCYZ8e0qlyc_FU46neoWjO7yTWj&index=45

Sub test()

Dim rngA As Range '전체 범위변수
Dim rngB As Range   'For Each를 위한 단일 셀 변수
Dim C As New Collection   '원하는 데이터를 담아줄 Collection선언

Set rngA = Range("C3", Cells(Rows.Count, "c").End(xlUp))
'ranA에는 C3부터 C열 마지막 행까지의 범위를 담아줘
'반복문을 통한 Collection에 값 담아주기

On Error Resume Next


For Each rngB In rngA
'rngA에서 하나의 셀씩 반복해줘
    If Len(rngB) Then  'rngB에 데이타가 있다면
                C.Add Trim(rngB), CStr(Trim(rngB))
               'C라는 Collection에 rngB의 앞뒤 공백을 제거하고 추가해주고,
                         'Key값으로는 CStr을 이용하여 앞뒤공백을 제거해준 rngB값으로 해줘
        End If
Next



Dim i As Long 'Collection을 반복문으로 값을 뿌려주기 위한 변수
     For i = 1 To C.Count ' Collecdtion C의 갯수만큼 반복해줘
     Cells(2 + i, "f") = C(i) '2+i행,f열에 C의 i번째 아이템을  넣어줘
Next

End Sub   '출처 :https://blog.naver.com/mrdjrblog/222456575897

한때는 식은 죽기로 사용했던 함수인데, 하도 엑셀을 사용한 오래되서 가물가물하다.