VB(A)

A시트와 B시트의 필터링 값을 각각의 파일로 저장

당근쨈 2015. 7. 27. 10:12
A에는 있지만 B에는 없는 것
A에는 없지만 B에는 있는 것
A와 B동시에 있는 것

세가지 조건을 충족하기 위해 애 좀 먹었다.

Option Explicit
Private rngWs1 As Range
Private rngWs2 As Range
Private wS1 As Worksheet
Private wS2 As Worksheet
Private wbOld As Workbook
Private varClt As Variant
Sub mkFile()
 
    Dim cltWs1 As New Collection
    Dim cltWs2 As New Collection
    Dim rng As Range
 
    Application.ScreenUpdating = False
 
    '각 시트 및 현재 워크북 변수 설정
    Set wS1 = Sheets(1)
    Set wS2 = Sheets(2)
    Set wbOld = ThisWorkbook
 
    '거래처 영역 변수 설정
    With wS1
        Set rngWs1 = .Range("A2", .Cells(Rows.Count, "A").End(xlUp))
    End With
 
    With wS2
        Set rngWs2 = .Range("A2", .Cells(Rows.Count, "A").End(xlUp))
    End With
 
    '각 시트의 거래처명을 중복값 제외하고 받아오기
    On Error Resume Next
    For Each rng In rngWs1
        cltWs1.Add rng, CStr(rng)
    Next rng
 
    For Each rng In rngWs2
        cltWs2.Add rng, CStr(rng)
    Next rng
    On Error GoTo 0
 
    fnMakeFile cltWs1, 0    'A시트에만 데이터가 있을 때
    fnMakeFile cltWs1, 1    'A,B시트에 데이터가 동시에 있을 때
    fnMakeFile cltWs2, 0    'B시트에만 데이터가 있을 때
 
    'A시트 필터링 제거
    wS1.ShowAllData
    wS2.ShowAllData
 
    Application.ScreenUpdating = True
End Sub
 
Sub fnMakeFile(cltCollection As Collection, intCount As Integer)
 
    Dim wbNew As Workbook
    Dim wsPaste As Worksheet
    Dim rngFor As Range
    Dim i As Integer
 
    Application.ScreenUpdating = False
 
    Select Case cltCollection.Item(1).Parent.Index
        Case 1
            Set rngFor = rngWs2
            Set wsPaste = wS1
        Case 2
            Set rngFor = rngWs1
            Set wsPaste = wS2
    End Select
 
    For Each varClt In cltCollection
        Select Case intCount
            Case 0
                If WorksheetFunction.CountIf(rngFor, varClt) = 0 Then
                    Workbooks.Add
                    Set wbNew = ActiveWorkbook
                    wbOld.Activate
                    With wsPaste.Range("A1")
                        .AutoFilter field:=1, Criteria1:=varClt
                        .CurrentRegion.Copy wbNew.Sheets(1).Range("A1")
                    End With
                End If
            Case 1
                If WorksheetFunction.CountIf(rngFor, varClt) Then
                    For i = 1 To 2
                        If i = 1 Then
                            Workbooks.Add
                            Set wbNew = ActiveWorkbook
                            wbOld.Activate
                        End If
                        With Sheets(i).Range("A1")
                            .AutoFilter field:=1, Criteria1:=varClt
                            .CurrentRegion.Copy wbNew.Sheets(i).Range("A1")
                        End With
                    Next i
                End If
        End Select
 
        If Not wbNew Is Nothing Then
            wbNew.Close savechanges:=True, Filename:=wbOld.Path & "\" & varClt & ".xlsx"
            Set wbNew = Nothing
        End If
    Next varClt
    Application.ScreenUpdating = True
End Sub
cs