[땡큐엑셀vba & 엑셀매크로] 파일명의 앞글자와 일치하는 폴더로 이동하기

실행전

 

 

실행 결과

 

'변수를 선언하고 사용하기
Option Explicit

' 파일명의 앞글자와 일치하는 폴더로 이동하기
' 예를 들어 파일명이 aaasddf.txt인 경우 "a파트"라는 폴더로 이동
'           파일명이 1zsdfd.exe인 경우 "1파트"라는 폴더로 이동
'
'source by 땡큐엑셀vba & 엑셀매크로
'
Sub 파일이동()


    Dim strPath As String                              '폴더의 경로를 넣을 변수
    Dim fileName As String                             '각 파일 이름을 넣을 변수
    Dim i As Integer
    Dim msg As String
    Dim 이동폴더명 As String
    
    
    
    'Application.ScreenUpdating = False         '화면 업데이트 (일시) 정지
    Cells.Clear
    
    
    ' 폴더 선택창
    With Application.FileDialog(msoFileDialogFolderPicker)  '폴더선택
        .Show                                               '폴더 선택창 띄우기
 
        If .SelectedItems.Count = 0 Then          '취소 선택시
            Exit Sub
        Else                                      '폴더를 선택한 경우
            strPath = .SelectedItems(1) & "\"     '폴더 경로를 변수에 넣음
        End If
    End With
    
    
    ' 폴더내 파일 유무 확인
    fileName = Dir(strPath & "*.*")               '모든 파일
 
    If fileName = "" Then                         '파일이 없으면
        MsgBox "파일이 없습니다.", vbInformation, "땡큐엑셀vba"               '메시지 출력
        Exit Sub                                  '매크로 중단
    End If
            
            
    Do While fileName <> ""                       '파일이 존재하면
    
        i = i + 1

        '파일의 첫글자를 가지고 폴더명 만들기
        이동폴더명 = Left(fileName, 1) & "파트\"
        
        If Dir(strPath & 이동폴더명, vbDirectory) = "" Then '해당 폴더가 없다면
            MkDir strPath & 이동폴더명  '폴더생성
        End If
        
        
        '파일의 첫글자와 동일한 폴더로 이동
        If Dir(strPath & 이동폴더명 & fileName) <> "" Then           '동일한 파일이 있으면 이동하지 않음
            msg = "Fail"
        Else
            msg = "OK"
            Name strPath & fileName As strPath & 이동폴더명 & fileName    '파일 이동
        End If


        '전체경로
        Cells(i, "A") = strPath & fileName
        '처리결과
        Cells(i, "B") = msg
        
        
        fileName = Dir(strPath & "*.*") '다음 파일
        
    Loop

    '열너비 자동 맞춤
    Columns.AutoFit
    
    '종료 메시지창 출력
    MsgBox "완료되었습니다.", vbInformation, "땡큐엑셀vba & 엑셀매크로"
    
End Sub

 

같은철자로시작하는 폴더로 파일이동-FileDialog_Dir_MkDir_Left_AutoFit-땡큐엑셀vba.xlsm

0.05MB