[땡큐엑셀vba & 엑셀매크로] 시트생성하여 업체별로 분리하기

분리전

 

Aa

B

 

ccc

 

'http://kin.naver.com/qna/detail.nhn?d1id=1&dirId=102020101&docId=282200498
'
'안녕하세요
'업무중 급한질문이 있어 질문드립니다ㅠㅠ
'예를들어 A열에는 업체명이 들어가있고 업체마다 다른양의 상품들이 쭉 나오는데요
'1,2행에 있는 제목란은 공통으로 들어가고 (행높이는 지정된것으로 +셀너비가 글자수에 맞춰 늘어나게끔)
'업체마다 엑셀을 다른이름(업체명)으로 저장해야합니다..
'각각의 파일은 A열에 있는 업체명으로 저장되어야합니다ㅠㅠ
'도움부탁드려요
'예시파일 첨부합니다!


' 시트생성하여 업체별로 분리하기

'
' source by 땡큐엑셀vba & 엑셀매크로
'
Sub 업체별분류()

    Dim srcOpt1 As Range
    Dim dstSht As String
    Dim dstOpt1 As String
    
    Dim 업체명 As String
    Dim 현재시트명 As String
    
    현재시트명 = ActiveSheet.Name
    
    '화면갱신 중지
    Application.ScreenUpdating = False
    
    '마지막행까지 루프돌며 작업
    마지막행 = Cells(Rows.Count, "A").End(xlUp).Row
    For i = 3 To 마지막행
    
        '시트확인및 생성
        업체명 = Cells(i, "A")
        If ExistSheet(업체명) Then
            '시트가 있을경우
        Else
            '시트가 없을경우 생성
            Worksheets.Add after:=Sheets(Worksheets.Count)
            Sheets(Worksheets.Count).Name = 업체명
            Sheets(현재시트명).Activate
            
        
            '헤더 복사
            Range("A1:R2").Select
            dstSht = 업체명
            Call 붙여넣기(dstSht)
        
        End If
    
    
        '업체별 내용 복사
        Range("A" & i & ":R" & i).Select
        dstSht = 업체명
        Call 붙여넣기(dstSht)
        
    Next i
     
    
    MsgBox "완료되었습니다.", vbInformation, "땡큐엑셀vba & 엑셀매크로"

End Sub


' source by 땡큐엑셀vba & 엑셀매크로
'시트의 마지막행에 붙여넣기
'dstSht  : 목적 시트명
Sub 붙여넣기(dstSht As String)

    '복사
    Selection.Copy
    
    마지막행 = Sheets(dstSht).Cells(Rows.Count, "A").End(xlUp).Row
    If 마지막행 = 1 Then
        복사행 = 마지막행
    Else
        복사행 = 마지막행 + 1
    End If
    
    
    '행삽입하며 붙여넣기
    Sheets(dstSht).Range("A" & 복사행).EntireRow.Insert Shift:=xlShiftDown, CopyOrigin:=xlFormatFromLeftOrAbove
    
    '복사모드 해제
    Application.CutCopyMode = flase
        
End Sub


' source by 땡큐엑셀vba & 엑셀매크로
'시트유무 확인
'있을경우 True, 없을경우 False 리턴
Function ExistSheet(strOpt1 As String) As Boolean

    Dim sht As Worksheet
    
    On Error Resume Next
    
    Set sht = Worksheets(strOpt1)
    
    If Err.Number = 0 Then
        ExistSheet = True
    Else
        ExistSheet = False
    End If
    
End Function

 

업체별분류-Worksheets.Add_Worksheets.Name_Copy_CutCopyMode-땡큐엑셀vba.xlsm

0.07MB