소프트웨어 엑셀 첫시트내용을 옮겨 따로 시트명과 내용을 옮기는 질문입니다.
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 | - | - |
100215 | 윈 도 우| 자료실의 Windows 7 Alienware Ultimate 32bit, 64bit에 대... | 소천 | 165000 | 10-01 |
100214 | 윈 도 우| 자료실의 Windows 7 Alienware Ultimate 32bit 받아볼수 없... [2] | 오백원 | 164132 | 10-10 |
100213 | 윈 도 우| 바로가기실행 아이콘의 동작불능 | 가난한사람 | 160533 | 01-31 |
100212 | 윈 도 우| 자료실의 Alienware Windows7의 로고를 원래대로 복원하는 ... [4] | 소천 | 150556 | 10-04 |
100211 | 윈 도 우| Windows 7의 관리 기능을 집약한 숨겨진 GodMode의 존재 [5] | 죠타로 | 123870 | 01-07 |
100210 | 윈 도 우| PE 시작메뉴랑 작업표시줄 숨길 수 없나요? [11] | 배추보쌈 | 107097 | 01-17 |
100209 | 기 타| html&css 중급자 이상자 분께 도움을 요청해봅니다,, [3] | ㄴ초심ㄱ | 102140 | 05-16 |
100208 | 하드웨어| KMS Activator에 대해서 질문있습니다. | 오잉!? | 85442 | 04-20 |
100207 | 윈 도 우| 카리스마조님의 바로가기 말인데요~ [1] | KOOL하게 | 84441 | 01-06 |
100206 | 윈 도 우| 가젯이 CPU 점유율 상승문제에 영향을 주는군요. [22] | BigShit | 83720 | 11-26 |
100205 | 윈 도 우| page fault in nonpaged area [1] | 한강한뺨뷰 | 80397 | 08-24 |
100204 | 윈 도 우| 인터넷 바로가기 관련 궁금한점이 있습니다. [1] | 도라란 | 79950 | 07-06 |
100203 | 윈 도 우| 모든 바로가기를 실행하면 연결프로그램 선택 창이 떠요ㅠㅠ [4] | 네버s2 | 73078 | 09-17 |
100202 | 윈 도 우| 9down.dom 같은 사이트 또 없나요 [3] | 애벌레 | 67526 | 12-10 |
100201 | 하드웨어| 문의)) "kms Server" 삭제 안하고 써도 괜찮나요??? [1] | Chobits0914 | 66897 | 04-29 |
100200 | 윈 도 우| suk님 시간되시면 부탁드립니다. [7] | 초보라서죄 | 65174 | 12-06 |
100199 | 하드웨어| 문의)) KMS인증과 가상바이오스 인증 중 안정적인 것은 어... [2] | Chobits0914 | 64592 | 06-17 |
100198 | 윈 도 우| win7 / vista god mode 활성화 시키기 [7] | 카츠라 | 61038 | 01-06 |
100197 | 윈 도 우| [A.I_7T]SLIC2.1 인증에대해.. [1] | 김간지 | 59009 | 01-23 |
안녕하세요?
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