vba 다른 파일에 있는 데이터를 검색하여 가져오기

VBA랑 그다지 친한 사이는 아니지만 아래와 같이 짜 봤습니다. 되도록 확장을 고려했고 예시하신 대로 외곽선, 셀 병합을 하도록 하다 보니 코드가 길어졌는데, 찬찬히 보시며 응용해 보세요.

 

(데이타에 셀 병합이 없을 경우)

	A	B	C	D	E
1	d:\data\excel\test\		가져올 열 수	2
2
3		2008-11-27
4		파일명	시트명	데이터1	데이터2
5		데이타1.xlsx	과일금속	사과	apple
6				복숭아	peach
7				포도	grape
8				배	pear
9		데이타2.xlsx	동물자연	개	dog
10				고양이	cat
11				호랑이	tiger
12			나라행성	일본	Japan
13				한국	Korea
14		데이타3.xlsx	교통통신	열차	train
15				비행기	airplane
16				버스	bus

 

1. A1에 가져올 화일들이 있는 디렉토리를 지정합니다. (제 OS가 일본어여서 위와 같이 찍힌 겁니다. 마지막 \까지 넣어줘야 합니다.)

2. D1에 한번에 가져올 열 수를 지정합니다. (예시에서 점심/5000 식으로 가로로 2개일 경우 2를 입력)

3. 아무 곳에서나 검색할 문자열을 입력한 후 (예시에서는 B3) 커서가 문자열에 위치된 상태에서 매크로를 가동하면 위와 같이 출력됩니다.

 

코드는 지정한 데이타의 모든 엑셀화일 (확장자가 *.xls*)의 모든 시트를 대상으로 사용된 영역(usedrange)를 검색, 같은 문자열을 찾습니다. 문자열이 걸리면 그 오른쪽 n열이 모두 빈칸이 아닌 경우 출력을 진행합니다. 그리고 아래 주소에 데이타가 없고 오른쪽 n열에 데이타가 하나라도 있는 경우 계속해서 출력을 진행합니다. 아래는 코드입니다.

 

Sub Data_Gathering()
'
' Data_Gathering Macro
' 디렉토리의 모든 화일/시트를 검색, 해당날짜 데이타 모두 가져오기
'
' Keyboard Shortcut: Ctrl+g
'

Dim sht As Worksheet        '검색대상 시트
Dim oB As String            'original book  취합 워크북 이름
Dim oS As String            'original sheet 취합 워크시트 이름
Dim lb As Integer           'line of workbook (현재 화일의 출력 시작 행)
Dim ls As Integer           'line of sheet    (현재 시트의 출력 시작 행)
Dim shtname As String       '검색 시트 이름
Dim DtDir As String         'data directory 지정 디렉토리 주소
Dim dtFile As String        'data file      화일명
Dim irow As Integer         '기준문자열 행 번호
Dim icol As Integer         '기준문자열 열 번호
Dim itotal As Integer       '찾은 데이타 행 수
Dim isht As Integer         '현재 시트에서 찾은 데이타 수
Dim ibook As Integer        '현재 화일에서 찾은 데이타 수
Dim tsht As Integer         '데이타가 검색된 시트 수
Dim tbook As Integer        '데이타가 검색된 화일 수
Dim colnum As Integer       '검색문자열로부터 오른쪽으로 데이타 가져올 열 수
Dim Tdata As Variant        '검색문자열
Dim rngcell As Range        '검색범위

 

Tdata = ActiveCell.Value
irow = ActiveCell.Rows(1).Row
icol = ActiveCell.Columns(1).Column
ls = irow + 2
lb = irow + 2
DtDir = Cells(1, 1)
colnum = Cells(1, 4)
oB = ActiveWorkbook.Name
oS = ActiveSheet.Name

 

dtFile = Dir(DtDir & "*.xls*")
If dtFile = "" Then
    MsgBox "no excel file in " & DtDir
    Exit Sub
End If

 

Do
Workbooks.Open DtDir & dtFile
    ibook = 0
    For Each sht In Worksheets
        sht.Activate
        isht = 0
        ActiveSheet.UsedRange.Select
            For Each rngcell In Selection
                If Tdata = rngcell.Value Then
                    chk = 0
                    For i = 1 To colnum
                        With rngcell
                        If .Offset(0, i) <> "" Then chk = 1
                        End With
                    Next i
                    If chk = 1 Then
                        j = 0
                        Do
                            For i = 1 To colnum
                                With rngcell
                                    k = icol + i + 1
                                    Workbooks(oB).Worksheets(oS).Cells(ls + isht, k) = .Offset(0 + j, i)
                                End With
                            Next i
                            isht = isht + 1
                            ibook = ibook + 1
                            itotal = itotal + 1
                           
                            j = j + 1
                            chk = 0
                            With rngcell
                                If .Offset(0 + j, 0) = "" Then
                                    For k = 1 To colnum
                                        If .Offset(0 + j, k) <> "" Then chk = 1
                                    Next k
                                End If
                            End With
                           
                        Loop While chk = 1
                    End If
                End If
            Next rngcell
           
            If isht > 0 Then
                shtname = ActiveSheet.Name
                Workbooks(oB).Worksheets(oS).Activate
                Cells(ls, icol + 1) = shtname
                Range(Cells(ls, icol + 1), Cells(ls + isht - 1, icol + 1 + colnum)).Select
                GoSub Border_Line
                Range(Cells(ls, icol + 1), Cells(ls + isht - 1, icol + 1)).Select
                GoSub Cell_Merge
                ls = ls + isht
                tsht = tsht + 1
                sht.Activate
            End If
   
    Next sht
   
    If ibook > 0 Then
        shtname = ActiveWorkbook.Name
        Workbooks(oB).Worksheets(oS).Activate
        Cells(lb, icol) = shtname
        Range(Cells(lb, icol), Cells(lb + ibook - 1, icol)).Select
        GoSub Border_Line
        GoSub Cell_Merge
        lb = lb + ibook
        tbook = tbook + 1
        Workbooks.Open DtDir & dtFile
    End If

ActiveWorkbook.Close
dtFile = Dir()
Loop Until dtFile = ""

 

Workbooks(oB).Worksheets(oS).Activate
MsgBox tbook & "파일, " & tsht & "시트에서" & itotal & "개의 행을 찾았습니다"

 

Exit Sub

 

'괘선그리기 서브루틴
Border_Line:
    Selection.Borders(xlDiagonalDown).LineStyle = xlNone
    Selection.Borders(xlDiagonalUp).LineStyle = xlNone
    With Selection.Borders(xlEdgeLeft)
        .LineStyle = xlContinuous
        .ColorIndex = xlAutomatic
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlEdgeTop)
        .LineStyle = xlContinuous
        .ColorIndex = xlAutomatic
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlEdgeBottom)
        .LineStyle = xlContinuous
        .ColorIndex = xlAutomatic
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlEdgeRight)
        .LineStyle = xlContinuous
        .ColorIndex = xlAutomatic
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlInsideVertical)
        .LineStyle = xlContinuous
        .ColorIndex = xlAutomatic
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlInsideHorizontal)
        .LineStyle = xlContinuous
        .ColorIndex = xlAutomatic
        .TintAndShade = 0
        .Weight = xlThin
    End With
    Return
   
'셀 병합 서브루틴
Cell_Merge:
    With Selection
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlCenter
        .WrapText = False
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = False
    End With
    Selection.Merge
    Return

End Sub

 

(데이타에 셀 병합이 있을 경우)

	A	B	C	D	E
1	d:\data\excel\test\		가져올 열 수	2
2
3		2008-11-27
4		파일명	시트명	데이터1	데이터2
5		데이타1.xlsx	과일금속	사과	apple
6					ringo
7				ship	배
8				pear
9		데이타2.xlsx	동물자연	개	dog
10				고양이	cat
11				호랑이	tiger
12			나라행성	일본	Japan
13				한국	Korea
14		데이타3.xlsx	교통통신	열차	train
15				비행기	airplane
16				버스	bus

 

디렉토리, 가져올 수 지정은 위와 마찬가지이고, 코드는 아래와 같습니다.

 

Sub Data_Gathering()
'
' Data_Gathering Macro
' 디렉토리의 모든 화일/시트를 검색, 해당날짜 데이타 모두 가져오기
'
' Keyboard Shortcut: Ctrl+g
'

Dim sht As Worksheet        '검색대상 시트
Dim oB As String            'original book  취합 워크북 이름
Dim oS As String            'original sheet 취합 워크시트 이름
Dim cB As String            'current book  대상 워크북 이름
Dim cS As String            'currnet sheet 대상 워크시트 이름
Dim lb As Integer           'line of workbook (현재 화일의 출력 시작 행)
Dim ls As Integer           'line of sheet    (현재 시트의 출력 시작 행)
Dim ll As Integer           'line of line     (현재 라인의 출력 시작 행)
Dim shtname As String       '검색 시트 이름
Dim DtDir As String         'data directory 지정 디렉토리 주소
Dim dtFile As String        'data file      화일명
Dim irow As Integer         '기준문자열 행 번호
Dim icol As Integer         '기준문자열 열 번호
Dim itotal As Integer       '찾은 데이타 행 수
Dim isht As Integer         '현재 시트에서 찾은 데이타 수
Dim ibook As Integer        '현재 화일에서 찾은 데이타 수
Dim tsht As Integer         '데이타가 검색된 시트 수
Dim tbook As Integer        '데이타가 검색된 화일 수
Dim colnum As Integer       '검색문자열로부터 오른쪽으로 데이타 가져올 열 수
Dim Tdata As Variant        '검색문자열
Dim rngcell As Range        '검색범위

 

Tdata = ActiveCell.Value
irow = ActiveCell.Rows(1).Row
icol = ActiveCell.Columns(1).Column
ll = irow + 2
ls = irow + 2
lb = irow + 2
DtDir = Cells(1, 1)
colnum = Cells(1, 4)
oB = ActiveWorkbook.Name
oS = ActiveSheet.Name

dtFile = Dir(DtDir & "*.xls*")

If dtFile = "" Then
    MsgBox "no excel file in " & DtDir
    Exit Sub
End If

 

Do
Workbooks.Open DtDir & dtFile
    ibook = 0

    For Each sht In Worksheets
        sht.Activate
        isht = 0
        ActiveSheet.UsedRange.Select
            For Each rngcell In Selection
                If Tdata = rngcell.Value Then
                    j = 0
                    Do
                        chk = 0
                        With rngcell
                            For i = 1 To colnum
                                If .Offset(j, i) <> "" Then chk = 1
                            Next i
                           
                            If j > 0 And .Offset(j, 0) <> "" Then chk = 0
                            If chk = 1 Then
                                j = j + 1
                                isht = isht + 1
                                ibook = ibook + 1
                                itotal = itotal + 1
                            End If
                        End With
                           
                    Loop While chk = 1
               
                    If j > 0 Then
                        With rngcell
                            Range(.Offset(0, 1), .Offset(j - 1, colnum)).Select
                            Selection.Copy
                        End With
                        cB = ActiveWorkbook.Name
                        cS = ActiveSheet.Name
                        Workbooks(oB).Worksheets(oS).Activate
                        Cells(ll, icol + 2).Select
                        ActiveSheet.Paste
                        ll = ll + j
                        Workbooks(cB).Worksheets(cS).Activate
                    End If
                End If
            Next rngcell
           
            If isht > 0 Then
                shtname = ActiveSheet.Name
                Workbooks(oB).Worksheets(oS).Activate
                Cells(ls, icol + 1) = shtname
                Range(Cells(ls, icol + 1), Cells(ls + isht - 1, icol + 1 + colnum)).Select
                GoSub Border_Line
                Range(Cells(ls, icol + 1), Cells(ls + isht - 1, icol + 1)).Select
                GoSub Cell_Merge
                ls = ls + isht
                tsht = tsht + 1
                sht.Activate
            End If
   
    Next sht
   
    If ibook > 0 Then
        shtname = ActiveWorkbook.Name
        Workbooks(oB).Worksheets(oS).Activate
        Cells(lb, icol) = shtname
        Range(Cells(lb, icol), Cells(lb + ibook - 1, icol)).Select
        GoSub Border_Line
        GoSub Cell_Merge
        lb = lb + ibook
        tbook = tbook + 1
        Workbooks.Open DtDir & dtFile
    End If

 

ActiveWorkbook.Close
dtFile = Dir()
Loop Until dtFile = ""

 

Workbooks(oB).Worksheets(oS).Activate
MsgBox tbook & "파일, " & tsht & "시트에서" & itotal & "개의 행을 찾았습니다"

 

Exit Sub

 

'괘선그리기 서브루틴
Border_Line:
    Selection.Borders(xlDiagonalDown).LineStyle = xlNone
    Selection.Borders(xlDiagonalUp).LineStyle = xlNone
    With Selection.Borders(xlEdgeLeft)
        .LineStyle = xlContinuous
        .ColorIndex = xlAutomatic
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlEdgeTop)
        .LineStyle = xlContinuous
        .ColorIndex = xlAutomatic
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlEdgeBottom)
        .LineStyle = xlContinuous
        .ColorIndex = xlAutomatic
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlEdgeRight)
        .LineStyle = xlContinuous
        .ColorIndex = xlAutomatic
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlInsideVertical)
        .LineStyle = xlContinuous
        .ColorIndex = xlAutomatic
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlInsideHorizontal)
        .LineStyle = xlContinuous
        .ColorIndex = xlAutomatic
        .TintAndShade = 0
        .Weight = xlThin
    End With
    Return
   
'셀 병합 서브루틴
Cell_Merge:
    With Selection
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlCenter
        .WrapText = False
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = False
    End With
    Selection.Merge
    Return

 

End Sub