복수의 시트 원하는 이름으로 한 번에 삽입하기 1

http://blog.naver.com/rosa0189/60135279544

 

 

Option Explicit
Sub add_Sheets_Before_And_After()

Dim colsCnt As Integer
Dim wkSht As Worksheet
Dim rngC As Range
Dim msg As String
Dim rowsCnt As Long
Dim varTemp
Dim i As Integer
Dim shtCnt As Integer

Application.ScreenUpdating = False
With Selection
colsCnt = .Columns.Count

shtCnt = ActiveSheet.Index
varTemp = Selection.Value '선택영역을 배열에 넣음
rowsCnt = .Rows.Count '선택영역의 셀 갯수 추출

If colsCnt > 1 Or .Areas.Count > 1 Then
MsgBox "1열 그리고 2행 이상만 선택하세요.", 64, "영역설정 에러"
Exit Sub
End If

For Each wkSht In ActiveWorkbook.Worksheets '중복되는 이름 검사
For Each rngC In Selection
If rngC = vbNullString Then
MsgBox "선택영역에 빈셀이 있습니다.", 64, "셀의 문자입력 오류"
Exit Sub
End If

If rngC.Value = wkSht.Name Then '만약 중복되는 이름 있으면 중단
MsgBox "시트이름[ " & wkSht.Name & " ]이 중복", 64, "시트이름 중복오류"
Exit Sub
End If
Next rngC
Next wkSht
End With

msg = MsgBox("시트를 앞에 삽입시 Yes, 뒤에 삽입시 No 선택", vbYesNoCancel, "위치 선택")
Select Case msg
Case vbYes 'Yes선택시
For i = rowsCnt To 1 Step -1 '선택영역의 셀 개수만큼
Worksheets.Add before:=Sheets(1) '선택영역 아래쪽부터 앞쪽에 시트 삽입
ActiveSheet.Name = varTemp(i, 1)
Next i
Sheets(shtCnt + rowsCnt).Activate 'Main 파일 활성화
Case vbNo 'No 선택 시
For i = 1 To rowsCnt '선택영역 셀 갯수만큼
Worksheets.Add after:=Sheets(Sheets.Count) '선택영역 윗쪽부터 뒷쪽에 시트 삽입
ActiveSheet.Name = varTemp(i, 1)
Next i
Sheets(shtCnt).Activate 'Main 파일 활성화
End Select

End Sub

[출처] (238) 복수의 시트 원하는 이름으로 한 번에 삽입하기 1 (엑셀 VBA 매크로)|작성자 니꾸