영역비교 추출

추석 연휴로 인해 며칠 지나지 않았는데도 벌써 내일 주말이 되었습니다. 별다른 일도 없고 해서
저번 아질게에 올라온 다중 영역 필터링에 대해 글을 쓰게 되었는데 아질게에 아무리 찾아보아도
관련 글이 보이지 않네요. 이제 늙으니 기억력에 문제가 생기는 …

저번에 팁란에 각 시트를 통합하고 그 통합된 시트에서 특정 데이터를 추출하는 법을 올렸습니다.
http://www.clien.net/cs2/bbs/board.php?bo_table=lecture&wr_id=286941
(엑셀(EXCEL) – 시트 통합, 월간년간보고서 작성 및 특정 자료(대리점) 추출)

이제 그 반대로 두 영역의 데이터를 상호 비교하여 같은 것이 있으면 추출하는 방법을 보겠습니다.
추출할 데이터가 몇 가지 되지 않으면 그냥 필터링을 해서 추가하고 또 필터링해서 추가하고 하면
되지만 예제에는 속도를 위해 몇 가지 데이터밖에 넣지를 않았지만 비교할 데이터가 몇백개 이상
넘어가면 수작업으로는 무리가 있습니다.

이제 VBA Editor 여시고 Module하나 만드시고 아래 코드를 복사하여 붙여넣기합니다.
코드 중간중간에 주석 달아놓았으니 필요한 부분을 수정, 첨삭하시어 사용하기 바랍니다.
한 루틴은 데이터를 비교하여 한 시트에 모아 주는 루틴이고 한 루틴은 각 데이터별로 시트를
만들어 분리해 주는 루틴입니다.

Option Explicit

Sub Ext_Same_Value()

Dim cnt As Integer

Dim rngCell As Range, rngTgt As Range
Dim rngR As Range, rngRef As Range

Dim tgt As Worksheet

‘ 경고 메시지 금지 및 속도를 위해 업데이트 중지
Application.DisplayAlerts = False
Application.ScreenUpdating = False

‘ 추출해서 붙여넣기할 데이터 시트가 기존에 있으면 삭제
For Each tgt In Worksheets
If tgt.Name = “ExtData” Then
tgt.Delete

End If
Next tgt

‘ 새 시트를 워크시트 제일 마지막에 ExtData라는 이름으로 추가
Set tgt = Worksheets.Add(after:=Worksheets(Worksheets.Count))
tgt.Name = “ExtData”

‘ 추출할 데이터 영역과 추출할 참조 영역 설정
Set rngTgt = Worksheets(“Data”).Range(“B:B”).SpecialCells(xlTextValues)
Set rngRef = Worksheets(“Ref”).Range(“A:A”).SpecialCells(xlTextValues)

‘ 두 영역을 순환하면서 같은 데이터가 있으면 추출 시트에 복사
For Each rngCell In rngTgt

For Each rngR In rngRef

If rngCell = rngR Then

tgt.Range(“A1”).Offset(cnt, 0).Value = rngCell.Offset(0, -1).Value
tgt.Range(“A1”).Offset(cnt, 1).Value = rngCell.Offset(0, 0).Value
tgt.Range(“A1”).Offset(cnt, 2).Value = rngCell.Offset(0, 1).Value
tgt.Range(“A1”).Offset(cnt, 3).Value = rngCell.Offset(0, 2).Value

cnt = cnt + 1

Exit For

End If

Next rngR

Next rngCell

‘ 보기 좋게 자동 칼럼 맞춤
tgt.Columns.AutoFit

‘ 경고 메시지 및 업데이트 갱신
Application.DisplayAlerts = True
Application.ScreenUpdating = True

End Sub

Sub Ext_Same_Value_To_Sheet()

Dim cnt As Long

Dim rngCell As Range, rngTgt As Range
Dim rngR As Range, rngRef As Range

Dim tgt As Worksheet

‘ 데이터 영역과 참조 영역 선택
Set rngTgt = Worksheets(“Data”).Range(“B:B”).SpecialCells(xlTextValues)
Set rngRef = Application.InputBox(“분리할 참조 영역 선택”, Type:=8)

Application.DisplayAlerts = False
Application.ScreenUpdating = False

Sheets(“Ref”).Activate

For Each rngR In rngRef

‘ 추출할 데이터의 시트가 있으면 삭제
For Each tgt In Worksheets
If tgt.Name = rngR Then
tgt.Delete

End If
Next tgt

‘ 추출할 데이터의 시트를 데이터 이름으로 추가
Worksheets.Add after:=ActiveSheet
ActiveSheet.Name = rngR

‘ 제목행 만듦
With Range(“A1”)
.Offset(0, 0).Value = Sheets(“Data”).Range(“A1”).Offset(0, 0).Value
.Offset(0, 1).Value = Sheets(“Data”).Range(“A1”).Offset(0, 1).Value
.Offset(0, 2).Value = Sheets(“Data”).Range(“A1”).Offset(0, 2).Value
.Offset(0, 3).Value = Sheets(“Data”).Range(“A1”).Offset(0, 3).Value

End With

‘ 순환하면서 같은 데이터가 있으면 새로 만든 시트에 추가
For Each rngCell In rngTgt

If rngR = rngCell Then

cnt = cnt + 1

With Range(“A1”)
.Offset(cnt, 0).Value = rngCell.Offset(0, -1).Value
.Offset(cnt, 1).Value = rngCell.Offset(0, 0).Value
.Offset(cnt, 2).Value = rngCell.Offset(0, 1).Value
.Offset(cnt, 3).Value = rngCell.Offset(0, 2).Value
End With

End If

Next rngCell

cnt = 0
Columns.AutoFit

Next rngR

Application.DisplayAlerts = True
Application.ScreenUpdating = True

End Sub

분리해야할 참조 영역이 정해져 있지 않아 특정 데이터 영역에서 추출해야하는 경우에는 아래의
팁을 응용하여 분리할 참조 영역을 중복되지않게 추출하고 그 추출된 데이터를 이용하여 두 영역을
비교하여 필요한 작업을 하시면 추출 관련해서는 이 두 팁을 이용하면 못할 것이 없을 것입니다.

http://www.clien.net/cs2/bbs/board.php?bo_table=lecture&wr_id=286263
(엑셀(EXCEL) – 임의 영역 중복항목 제거 루틴을 응용한 다대다(多對多) 항목 역전개(기준항목
변경))

첨부 화일 :  20151002-두 영역 비교하여 같은 값 추출 및 시트별로 분리