| |
Sub split_As_per_Rows() '// 지정한 행만큼씩 파일을 나눠서 저장하는 VBA
Dim Counter As String
Dim rngAll As Range '//모든 영역을 저장할 변수
Dim SplitLine As Integer '//몇 행씩 나눌지를 정하는 변수
Dim rowsCount As Long, colsCount As Integer '//행 및 열의 갯수 저장할 변수
Dim strPath As String '//파일저장 경로를 넣을 변수
Dim i As Long '//반복구문 숫자 증가에 사용할 변수
Dim rngSplit As Range '//나누어진 영역을 저장할 변수
Dim strName As String
Counter = InputBox("분할할 행의 수 입력하세요")
If Counter = "" Then Exit Sub '// 취소 선택시 매크로 중단
If Not IsNumeric(Counter) Then Exit Sub '// 입력한 값이 숫자가 아닌 경우
Application.ScreenUpdating = False '//화면 업데이트 (일시)정지
Set rngAll = ActiveSheet.UsedRange '//사용전체영역을 변수에 넣음
SplitLine = Counter '// 입력한 숫자 만큼 파일이 나눠서 저장
rowsCount = rngAll.Rows.Count '//전체 행의 숫자를 행 변수에 넣음
colsCount = rngAll.Columns.Count '//전체 열의 숫자를 열 변수에 넣음
strPath = ThisWorkbook.Path & Application.PathSeparator '//현재 파일이 있는 경로에 저장
With ThisWorkbook
strName = Left(.Name, Len(.Name) - 5) '//Excel 파일의 확장자 제거. 만약 xls 파일이면 숫자를 4로 변경
End With
For i = 1 To rowsCount Step SplitLine '//SplitLine 만큼씩 증가하며 반복
Set rngSplit = Range(Cells(i + 1, 1), Cells(i + SplitLine, colsCount)) '//나누어진 영역을 변수에 넣음
Workbooks.Add '//새로운 workbook을 생성
rngAll.Rows(1).SpecialCells(2).Copy Cells(1, 1) '//첫줄 제목을 각 workbook에 복사
rngSplit.Copy '//2번째 행부터 SplitLine 만큼 나누어진 영역을 복사
With Cells(2, 1)
.PasteSpecial Paste:=xlPasteValues '// 값 복사
End With
Range("E1").Select
ActiveWorkbook.SaveAs strPath & strName & "(" & ((i - 1) \ SplitLine) + 1 & ").xlsx", FileFormat:=xlOpenXMLWorkbook
'//현재 파일이 있는 경로에 현재파일명 + SplitLine 만큼씩 나눠서 몫으로 카운트하면서 저장
ActiveWorkbook.Close '//새로 만든 workbook을 저장
Next i
Set rngAll = Nothing '//개체변수들 초기화(사용 메모리 비우기)
Set rngSplit = Nothing '//개체변수들 초기화(사용 메모리 비우기)
End Sub
=======================================================================
엑셀 분할 매크로 소스 입니다
이 매크로로는 전체 시트 첫번째 줄 복사 + 분할 행 입력값으로 파일을 나눠주는데.. 전체 시트 첫번째 ~ 3번째 줄 복사 + 분할 행 입력값으로 수정을 하고 싶습니다.ㅠㅠ
==============[차니찬님 글에 대한 답변입니다]==============
사실 어떤 문제의 해결 방법에는 유일한 정답만 있는 것이 아니고
여러가지 알고리즘이 가능하며
프로그래머마다 개성이 있고 선호하는 알고리즘이나 명령어 체계가 있어서
다른 사람이 작성한 프로그램을 수정한다는 것은
차라리 주어진 문제를 내가 즐겨쓰는 독특한 방법으로 새로 개발하는 것보다 더 힘들 때가 있답니다.
짬짬이 분석하여 해법을 내 봅니다.
수정하거나 첨가한 코드는 주석에 ***** 기호를 표시하였으니 참고하시기 바랍니다.
각 분할 파일마다 포함시킬 헤더 행의 수를 입력 받도록 하였으므로
주문하신 것보다 훨씬 융통성 있는 프로그램이 되겠지요.
다만, 원래 코드를 그렇게 설계하셨듯이
분할되는 몸체 부분을 '값으로 붙여넣기' 하셨기 때문에
서식이나 열 폭 같은 중요 환경이 복사되지 않아서
예컨대 날짜 데이터가 이상한 숫자로 바뀌어 보인다든가
열 폭이 좁아서 큰 수는 ### 등으로 보이는 현상이 생길 수 있습니다.
==================================
Sub split_As_per_Rows() '// 지정한 행만큼씩 파일을 나눠서 저장하는 VBA
Dim Header As String '//헤더 행의 수를 입력받기 위한 변수 *****
Dim Counter As String
Dim rngAll As Range '//모든 영역을 저장할 변수
Dim SplitLine As Integer '//몇 행씩 나눌지를 정하는 변수
Dim HeadRow As Integer '//헤더 행의 수 *****
Dim rngHead As Range '//헤더 영역을 저장할 변수 *****
Dim rowsCount As Long, colsCount As Integer '//행 및 열의 갯수 저장할 변수
Dim strPath As String '//파일저장 경로를 넣을 변수
Dim i As Long '//반복구문 숫자 증가에 사용할 변수
Dim rngSplit As Range '//나누어진 영역을 저장할 변수
Dim strName As String
Header = InputBox("각 파일에 공통으로 포함할 헤더 행의 수 입력하세요") '//*****
If Header = "" Then Exit Sub '// 취소 선택시 매크로 중단 *****
If Not IsNumeric(Header) Then Exit Sub '// 입력한 값이 숫자가 아닌 경우 *****
Counter = InputBox("분할할 행의 수 입력하세요")
If Counter = "" Then Exit Sub '// 취소 선택시 매크로 중단
If Not IsNumeric(Counter) Then Exit Sub '// 입력한 값이 숫자가 아닌 경우
Application.ScreenUpdating = False '//화면 업데이트 (일시)정지
Set rngAll = ActiveSheet.UsedRange '//사용전체영역을 변수에 넣음
SplitLine = Counter '// 입력한 숫자 만큼 파일이 나눠서 저장
rowsCount = rngAll.Rows.Count '//전체 행의 숫자를 행 변수에 넣음
colsCount = rngAll.Columns.Count '//전체 열의 숫자를 열 변수에 넣음
HeadRow = Header '// *****
Set rngHead = Range(Cells(1, 1), Cells(HeadRow, colsCount)) '//헤더 영역을 변수에 넣음 *****
strPath = ThisWorkbook.Path & Application.PathSeparator '//현재 파일이 있는 경로에 저장
With ThisWorkbook
strName = Left(.Name, Len(.Name) - 5) '//Excel 파일의 확장자 제거. 만약 xls 파일이면 숫자를 4로 변경
End With
'***** 반복루프의 시작값을 헤더영역의 끝부터 도는 것으로 수정함 *****
For i = HeadRow To rowsCount Step SplitLine '//헤더의 아래부터 SplitLine 만큼씩 증가하며 반복
Set rngSplit = Range(Cells(i + 1, 1), Cells(i + SplitLine, colsCount)) '//나누어진 영역을 변수에 넣음
Workbooks.Add '//새로운 workbook을 생성
rngHead.Copy Cells(1, 1) '//헤더 부분을 각 workbook에 복사 *****
rngSplit.Copy '// SplitLine 만큼 나누어진 영역을 복사
' /***** 헤더의 아래에 *******************************************
Cells(HeadRow + 1, 1).PasteSpecial Paste:=xlPasteValues '// 값 복사
Range("E1").Select
ActiveWorkbook.SaveAs strPath & strName & "(" & ((i - 1) \ SplitLine) + 1 & ").xlsx", FileFormat:=xlOpenXMLWorkbook
'//현재 파일이 있는 경로에 현재파일명 + SplitLine 만큼씩 나눠서 몫으로 카운트하면서 저장
ActiveWorkbook.Close '//새로 만든 workbook을 저장
Next i
Set rngAll = Nothing '//개체변수들 초기화(사용 메모리 비우기)
Set rngHead = Nothing '//개체변수들 초기화(사용 메모리 비우기) *****
Set rngSplit = Nothing '//개체변수들 초기화(사용 메모리 비우기)
End Sub
|
|
엑셀에 대한 질문과
답변을 올려주세요. 단, 취지에 맞지 않는 글은 운영자가 삭제합니다.
