소프트웨어 엑셀 첫시트내용을 옮겨 따로 시트명과 내용을 옮기는 질문입니다.

안녕하세요?

D열 중간에 Paper xxx부터 다음 빈셀까지 범위로 하여 자릅니다.

P1000 시트를 선택 후 아래 매크로를 실행해보십시오. 업무중 급히 만든 것이라 최적화는 안되어 있습니다.

Sub split_by_Paper()

    Application.ScreenUpdating = False

    Set src = ActiveSheet

    Do

        i = i + 1

        Set f = src.Range("D:D").Find(What:="Paper " & i, After:=ActiveCell, LookAt:=xlWhole)

        If f Is Nothing Then Exit Do

        f.Offset(1, 0) = f.Text & ". " & f.Offset(1, 0)

        f.Clear: f.Offset(1, 0).Select

        Range(Selection, Selection.End(xlDown)).EntireRow.Cut

        Sheets.Add.Name = "P" & 1000 + i

        ActiveSheet.Paste

        src.Activate

    Loop While i > 0

    Application.ScreenUpdating = True

End Sub

지후빠님 정말 감사합니다.

한번 해보겠습니다. 코딩은 역시 넘사벽이네요.

Happy time.

이 코드도 참고하세요.

Sub copy_chapters()

Dim ws As Worksheet

Dim re

Dim last_row As Long

Dim i As Long

Dim cell_info As String

Dim list As Collection

Dim first_row As Long

Dim end_row As Long

Application.ScreenUpdating = False

Set ws = Sheet1

ws.Activate '시트 P1000을 활성화

Set re = CreateObject("VBScript.RegExp") '정규식으로 Paper 000을 찾기

re.Pattern = "Paper\s\d{1,3}" 'Paper 세자리 수까지 커버.

last_row = Cells(Rows.count, 1).End(xlUp).Row() 'A열의 마지막 행

Set list = New Collection

For i = 1 To last_row

    If re.test(Trim(Cells(i, 4))) Then 'Paper 000인지 확인

        list.Add i '리스트에 저장

    End If

Next

For i = 1 To list.count

    If i = list.count Then

        first_row = list.Item(i) '복사할 첫번째 행

        end_row = last_row '복사할 마지막 행

    Else

        first_row = list.Item(i) '복사할 첫번째 행

        end_row = list.Item(i + 1) - 1 '복사할 마지막 행

    End If

    Range(Cells(first_row, 1), Cells(end_row, 6)).Copy '복사범위 지정

    cell_info = Trim(Cells(first_row, 4)) '시트 명

    Sheets.Add.Name = cell_info '새 시트 생성

    ActiveSheet.Paste Destination:=Range("a1") '새 시트에 붙여넣기

    Application.CutCopyMode = False

    ws.Activate '다시 원본 시트로 돌아가기

Next

Application.ScreenUpdating = True

End Sub

질문에 올려주신 파일로 해보시면 될거에요.

그 파일에는 첫번째 시트가 Sheet1(P1000)으로 되어 있고, 지금 올려주신 이미지에는 Sheet2(P1000)로 되어 있어서 에러가 나는거 같아요.

탭명(P1000)은 어떤 것이든 상관없는데 시트가 Sheet1에서 Sheet2로 바껴서 안될거에요.

오후9시7분님 도움 감사드립니다.

알려주신대로 한번 해보겠습니다. 

Happy day!

지후빠님, 오후9시7분님께,

도움 감사드립니다. 제가 잘못한 부분을 알려주셔서 다시 살펴보아 시행하니 잘 되었습니다.

정말 감사드립니다.

P.S. P1000의 첫 행 제목이 P1001~~~~ 등으로 시트가 만들어질 때, 제목으로 가야되는데 제가 언급을 못해 죄송합니다.

P1000의 첫 행 제목이 P1001~~~ 첫행 제목으로 가는 코딩 한 수를 더 부탁드립니다.

오늘도 해피데이!

Sub split_by_Paper()

    Application.ScreenUpdating = False

    Set src = ActiveSheet

    Set ttl = src.Range("A1:F1")

    Do

        i = i + 1

        Set f = src.Range("D:D").Find(What:="Paper " & i, After:=ActiveCell, LookAt:=xlWhole)

        If f Is Nothing Then Exit Do

        f.Offset(1, 0) = f.Text & ". " & f.Offset(1, 0)

        f.Clear: f.Offset(1, 0).Select

        Range(Selection, Selection.End(xlDown)).EntireRow.Cut

        Sheets.Add.Name = "P" & 1000 + i

        ActiveSheet.Range("A1:F1").Value = ttl.Value

        ActiveSheet.Range("A2").Select

        ActiveSheet.Paste

        src.Activate

    Loop While i > 0

    Application.ScreenUpdating = True

End Sub

split_by_Paper.bas

'1001 - P1000에서 실행시 입력

'2032 - P2000에서 실행시 입력

'3057 - P3000에서 실행시 입력

'4120 - P4000에서 실행시 입력

Sub split_by_Paper()

    Application.ScreenUpdating = False

    sNo = InputBox("시작할 번호를 입력하시오.", "시작번호", 1001)

    If Not sNo > 1000 Then Exit Sub

    Set srcSht = ActiveSheet

    Set Title = srcSht.Range("A1:N1")

    srcSht.Range("D1").Select

    Do

        i = sNo Mod 1000

        Set foundCel = srcSht.Range("D:D").Find(What:="Paper " & i, After:=ActiveCell)

        If foundCel Is Nothing Then Exit Do

        j1 = Left(CStr(sNo), 1)

        j3 = Right(CStr(sNo), 3)

        With foundCel

            .Offset(1, 0) = "PaperE" & j1 & " " & j3 & ". " & StrConv(.Offset(1, 0), vbProperCase)

            For k = 3 To 9 Step 3

                .Offset(1, k) = "PaperK" & j1 & " " & j3 & "." & .Offset(1, 9)

            Next k

            .EntireRow.Clear

            .Offset(1, 0).Select

        End With

        Range(Selection, Selection.End(xlDown)).EntireRow.Cut

        Sheets.Add.Name = "P" & sNo

        With ActiveSheet

            .Range("A1:N1").Value = Title.Value

            .Range("A2").Select

            .Paste

            .Range("D:D,G:G,J:J,M:M").ColumnWidth = 40

            .Range("A1").Select

        End With

        srcSht.Activate

        sNo = sNo + 1

    Loop While i > 0

    Application.ScreenUpdating = True

End Sub