소프트웨어 엑셀 첫시트내용을 옮겨 따로 시트명과 내용을 옮기는 질문입니다.
2023.08.28 13:09
엑셀 첫시트내용을 옮겨 따로 시트명과 내용을 옮기는 질문입니다.
첨부한 파일에 보면 191행에 Paper 1이 있습니다.
테스트용으로 Paper 20까지 올렸습니다.
1. Paper 1 -> P1001로 시트를 만든다.
~ Paper 20 -> -> P1020
2. 만들어진 시트에서 시트 이름에 따른 내용을 옮긴다.
예를 들어 P1001시트에는 Paper 1이 있는 행부터 Paper 2가 있느 행 전까지
~P1020 시트에는 Paper 20이 있는 행부터 마지막 내용이 있는 행까지
3. 바뀌는 김에 아래의 내용은 다음처럼 바뀌면 좋겠습니다. 이것도 20개가 되겠지요. 그러면 Paper 000이 있는 다음 공란 행은 삭제가 되면 좋겠습니다.
바뀔 행 내용: Paper 1. The Universal Father (headline 스타일)
원 행 2행 내용
Paper 1
The UNIVERSAL FATHER
1. 2번은 단번에 되어야 하겠고,
3.번은 따로 VBA가 되어야 하지 않을까 하는 생각이 듭니다.
고수가 보면 간단할 것 같은데, 초보자 입장에서는 넘사벽이네요.
고수님들의 도움을 부탁드립니다.
댓글 [12]
-
지후빠 2023.08.28 15:19
-
파풍초 2023.08.28 15:45
지후빠님 정말 감사합니다.
한번 해보겠습니다. 코딩은 역시 넘사벽이네요.
Happy time.
-
파풍초 2023.08.28 15:55
지후빠님께,
원하는대로 잘 실행이 되었습니다. 감사합니다. ^.^
-
지후빠 2023.08.28 16:20
확인 감사합니다. ^^
-
오후9시7분 2023.08.28 16:06
이 코드도 참고하세요.
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
-
파풍초 2023.08.28 22:59
도움 감사드립니다.
위의 코딩을 넣어니 에러나 나네요. 첨부 사진과 파일 체크 부탁드립니다.
Happy night!
-
오후9시7분 2023.08.29 10:14
질문에 올려주신 파일로 해보시면 될거에요.
그 파일에는 첫번째 시트가 Sheet1(P1000)으로 되어 있고, 지금 올려주신 이미지에는 Sheet2(P1000)로 되어 있어서 에러가 나는거 같아요.
탭명(P1000)은 어떤 것이든 상관없는데 시트가 Sheet1에서 Sheet2로 바껴서 안될거에요.
-
파풍초 2023.08.29 11:36
오후9시7분님 도움 감사드립니다.
알려주신대로 한번 해보겠습니다.
Happy day!
-
파풍초 2023.08.29 12:10
지후빠님, 오후9시7분님께,
도움 감사드립니다. 제가 잘못한 부분을 알려주셔서 다시 살펴보아 시행하니 잘 되었습니다.
정말 감사드립니다.
P.S. P1000의 첫 행 제목이 P1001~~~~ 등으로 시트가 만들어질 때, 제목으로 가야되는데 제가 언급을 못해 죄송합니다.
P1000의 첫 행 제목이 P1001~~~ 첫행 제목으로 가는 코딩 한 수를 더 부탁드립니다.
오늘도 해피데이!
-
지후빠 2023.08.29 13:25
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
-
파풍초 2023.08.29 16:46
지후빠님, 수고해주셔서 정말 감사드립니다.
해피데이.
-
지후빠 2023.08.30 20:24
'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
안녕하세요?
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