소프트웨어 엑셀 첫시트내용을 옮겨 따로 시트명과 내용을 옮기는 질문입니다.
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
번호 | 제목 | 글쓴이 | 조회 | 등록일 |
---|---|---|---|---|
[공지] | 질문과 답변 게시판 이용간 유의사항 | gooddew | - | - |
97910 | 소프트웨어| 레인미터 Network에 IP주소 안나오는 문제 (사진 및 파일 ... [1] | 아킬레스님 | 121 | 09-29 |
97909 | 소프트웨어| mp3 to mr 로 변환할 수 있는 프로그램(유틸리티)이 있나요. [2] | 덕산선생 | 232 | 09-29 |
97908 | 윈 도 우| 안녕하세요 pe구합니다 [2] | 넥스트타인 | 388 | 09-29 |
97907 | 소프트웨어| 엑셀 수식 질문입니다. [2] | 파풍초 | 263 | 09-28 |
97906 | 소프트웨어| 레인미터 스킨 (드라이브) 어디서 다운받을수 있을까요? (... [2] | 아킬레스님 | 291 | 09-28 |
97905 | 소프트웨어| 한글화 가능하신분 [4] | 淸樂 | 550 | 09-28 |
97904 | 하드웨어| 바탕화면 [1] | 수담 | 435 | 09-28 |
97903 | 하드웨어| Amd 5625u 노트북 램 증설시 [8] | 한스 | 284 | 09-27 |
97902 | 윈 도 우| ARM 윈도우는 USB 부팅이 안되나요? [2] | MSTSC | 416 | 09-27 |
97901 | 윈 도 우| 윈도우10 / 11 기본 메모리 점유율 차이가 있나요 [5] | MSTSC | 537 | 09-27 |
97900 | 소프트웨어| 정규식에서 제목을 헤드라인 형식으로 바꾸는 질문입니다. [10] | 파풍초 | 159 | 09-27 |
97899 | 윈 도 우| win11 22h2 KB5030310 업데이트 후 아이콘 글자 번짐 현상 [2] | 오두막과시 | 396 | 09-27 |
97898 | 소프트웨어| D-Snapshot 복원 문의 [4] | 유노 | 247 | 09-27 |
97897 | 윈 도 우| 네트워크 드라이브 연결 에서 시스템에 파일을 엑세스 할 ... | brucex | 148 | 09-27 |
97896 | 윈 도 우| 드라이버 백업 [2] | 어차피 | 330 | 09-27 |
97895 | 소프트웨어| 정규표현식 질문입니다. 도움을 부탁드립니다. ^.^ [2] | 파풍초 | 187 | 09-27 |
97894 | 윈 도 우| HDMI 연결 시 소리가 안납니다.2 [13] | 『ⓖⓤⓝ』 | 414 | 09-27 |
97893 | 윈 도 우| 윈도우 20H2-> LTSC 버전 변경 문의 [5] | koyotp | 401 | 09-26 |
97892 | 윈 도 우| 윈도우10 사진 앱 오프라인으로 재설치 하는 방법 문의 드... [2] | dlawlsfhr | 267 | 09-26 |
97891 | 소프트웨어| 드라이브 이미지 | 도파니 | 307 | 09-25 |
안녕하세요?
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