(1587) 폴더내 모든 파일의 열 불러오기

http://blog.naver.com/rosa0189/60209471570     첨부파일은 이곳에

1. 폴더내 모든 엑셀 파일내에 있는 특정 시트(예제에서는 Sheet1) 특정 열(예제에서는 C열)에 있는 모든 데이터를 가져오는 기능.
2. 데이터는 현재시트 B열 부터 오른쪽 열에 순차적으로 입력
3. 1행에는 가져온 데이터의 파일 이름을 입력
    

매크로 실행 전

 

매크로 실행 후 결과 

 

 

동영상의 순서별 설명 :

1. 폴더내에 여러 엑셀 파일이 있음
2. 파일을 열면 Sheet1 이 있고, 데이터가 있으며, 이 데이터의 C열만 가져오려고 함
3. 매크로 실행 후 폴더 선택창이 나타나면 파일이 들어 있는 폴더를 선택함
4. 매크로 종료 창이 출력되며 데이터를 가져옴.

 

 

Option Explicit

Sub combine_columns_In_Folder_1()

    Dim strSht As String                                       '시트 이름을 넣을 변수
    Dim strPath As String                                     '폴더의 경로를 넣을 변수
    Dim fileName As String                                   '각 파일 이름을 넣을 변수

    Dim strCol As String                                      '가져올 열 넣을 변수
    Dim rngT As Range                                        '각 열이 복사될 위치 넣을 영역변수
   

    Application.ScreenUpdating = False                 '화면 업데이트 (일시) 정지
    ActiveSheet.UsedRange.Offset(, 1).ClearContents
                                                                       '기존데이터 삭제 

    strSht = "Sheet1"                                           '데이터가 저장된 시트의 이름 

    strCol = "$C:$C"                                           '가져올 열을 변수에 넣음
 
    '-------------------------------------------------
    ' 폴더 선택하는 창 출력 후 폴더 경로 추출하는 코드
    '-------------------------------------------------
    With Application.FileDialog(msoFileDialogFolderPicker)  '폴더선택 창에서
        .Show                                                     '폴더 선택창 띄우기
 
        If .SelectedItems.Count = 0 Then                 '취소 선택 시
            Exit Sub                                               '매크로 중단
        Else                                                        '폴더를 선택한 경우
            strPath = .SelectedItems(1) & "\"           '폴더 경로를 변수에 넣음
        End If
    End With
    
    '-------------------------------------
    ' 폴더내 엑셀파일 유무를 확인하는 코드
    '-------------------------------------
    fileName = Dir(strPath & "*.xls*")                    '(폴더내)각 엑셀파일 이름을 변수에 넣음
 
    If fileName = "" Then                                      '폴더에 파일이 없으면
        MsgBox "폴더에 엑셀 파일이 없음."             '메시지 출력
        Exit Sub                                                   '매크로 중단
    End If
            
    Do While fileName <> ""                                 '이름이 없지 않다면, 즉, 파일이 존재하면
 

        '-----------------------------------------------------------------

        ' 배열수식을 이용하여 데이터 가져오고 수식을 값으로 변환하는 코드
        '-----------------------------------------------------------------

        Set rngT = Cells(1, Columns.Count).End(1)(1, 2) '각 열이 복사되는 기준위치를 변수에
        
        rngT.Formula = "=COUNTA('" & strPath & "[" & fileName & "]" _
            & strSht & "'!" & strCol & ")"                   'C열의 데이터 개수를 찾아 변수에 넣음
                                                                          
        With rngT.Offset(1).Resize(rngT.Value)        '각 열의 데이터
            .FormulaArray = "='" & strPath & "[" & fileName & "]" _
                & strSht & "'!" & Cells(1, 3).Resize(rngT.Value).Address(1, 1, 1)
                                                                       '데이터 영역을 배열 이용하여 가져옴
            .Value = .Value                                      '셀의 수식을 값으로 바꿈
        End With
        
        rngT = fileName                                         '1행에 파일 이름을 넣음
        
        fileName = Dir                                            '다음 파일을 파일이름에 넣음
    Loop                                                            '무한 반복
 

    Columns.AutoFit                                            '열너비 자동 맞춤
    
    MsgBox "매크로가 종료되었습니다."                 '종료 메시지창 출력
End Sub