같은 자료를 하나의 셀로 보여주도록 처리하는 VBA 코드이다.
첨부파일에는 여러개의 코드가 포함되어 있다.
VBA 고수분이 알려준 코드도 같이 포함되어 있고, 초보적인 수준으로 만든 코드도 포함되어 있다.
Sub collection2()
Dim sht1, sht2 As Worksheet '// 다른 시트 자료 가져오는 것까지 고려한 변수 선언
Dim rngC, rngT, rngData As Range
Dim X As New collection
Dim r, n, i As Long
Dim Dat As Variant
Application.ScreenUpdating = False '// 화면 업데이트 (일시) 중지
Set sht1 = Sheets("Main") '// 화면에 뿌릴 시트
Set sht2 = Sheets("Data") '// 가져올 데이터 시트
Range("G2:H" & Cells(Rows.Count).Row).Offset(1).ClearContents '// 결과를 뿌릴 화면 초기화
Set rngData = sht2.Range(sht2.Cells(4, "B"), sht2.Cells(Rows.Count, "B").End(3)) '// 가져올 데이터 영역
On Error Resume Next '// 에러가 발생했을 경우 계속해서 다음을 실행하라
r = 2
For Each rngC In rngData '// 데이터 시트의 B3셀부터 B의 마지막셀까지 반복하라
X.Add rngC.Value, CStr(rngC.Value) '// 중복된 데이터는 저장하지 마라
If Err.Number <> 457 Then '// 만일 에러가 발생하지 않았으면
r = r + 1
Cells(r, "G") = rngC
End If
Err.Clear
Next rngC
For Each rngT In Range([G3], Cells(Rows.Count, "G").End(3))
ReDim Dat(1 To 1): n = 0 '// 배열 및 배열에 사용할 변수 초기화
For Each rngC In rngData
If rngC = rngT Then
n = n + 1 '// 사용할 배열의 크기를 1씩 늘려감
ReDim Preserve Dat(1 To n) '// 기존값을 유지하면서 배열크기를 다시 설정
Dat(n) = rngC.Offset(, 1)
End If
Next rngC
rngT.Offset(, 1) = Join(Dat, ", ")
Next rngT
Set rngData = Nothing '// 메모리 비우기
End Sub
'업무 능력 향상 > 엑셀 VBA 활용' 카테고리의 다른 글
[VBA] 선택한 폴더의 모든 파일 가져오기 (0) | 2015.06.18 |
---|---|
[VBA] 중복되는 자료만 찾아서 배경색 저장 (0) | 2015.06.17 |
[VBA]한셀내에 콤마가 있는 데이터 분리 (0) | 2015.06.12 |
[VBA] 2개의 조건을 만족하면서 중복없는 데이터 가져오기 (0) | 2015.06.11 |
[VBA] 항목별 갯수 구하기 (0) | 2015.06.09 |