| |
* 답변하시는 분들께 도움이 되도록 자신의 환경을 아래 항목 옆에 기재해 주세요.
- 엑셀 버전(95,97,2000,xp,2003,2007):
* 아래줄에 질문을 작성하세요 >>
매번 어려움을 해결해주셔서 정말 감사드립니다.
염치없지만 다시한 번 부탁을 드려봅니다.
메인시트에 있는 표서식에서 만약 a열너비 10, b열너비 5, c열너비 7 등등 행높이가 30 등등 메인시트에 있는서식에 있는 행,열너비 그대로 다른시트가 작성되게 할 순 없는지요. 메인시트의 열너비나 행높이를 변경해서 실행하면 그대로 적용될 수 있도록 말입니다. 인쇄하려고 하면 매번 행,열너비를 다시 맞추고 하려면 어려울거 같아서요..
==============[카스님 글에 대한 답변입니다]==============
아래와 같이 수정하세요...
Sub CreateEachSheet()
Dim sht As Worksheet, shtTmp As Worksheet
Dim rData As Range, rRow As Range
Dim rFind As Range, rTg As Range
Dim sAddr As String
With Application
.ScreenUpdating = False
.Calculation = xlCalculationManual
.EnableEvents = False
End With
Set sht = ThisWorkbook.Worksheets("main")
Set rData = sht.Range("A1").CurrentRegion
For Each rRow In rData.Offset(2).Resize(rData.Rows.Count - 2).Rows
If rRow.Cells(1, 1) = "계" Then
Else
Set shtTmp = getSheet(rRow.Cells(1, 3), rData.Rows("1:2"))
Set rFind = shtTmp.Columns(1).Find(What:=rRow.Cells(1, 1), LookAt:=xlWhole)
If Not rFind Is Nothing Then
If InStr(rFind.Cells(1, 2), rRow.Cells(1, 2)) > 0 Then
Else
rFind.Cells(1, 2) = rFind.Cells(1, 2) & "," & rRow.Cells(1, 2)
rFind.Cells(1, 5) = rFind.Cells(1, 5) + rRow.Cells(1, 5)
rFind.Cells(1, 6) = rFind.Cells(1, 6) + rRow.Cells(1, 6)
End If
Else
Set rTg = shtTmp.Cells(Rows.Count, 1).End(xlUp)
If rTg = "계" Then
rTg.EntireRow.Insert
Set rTg = rTg.Offset(-1)
Else
Set rTg = rTg.Offset(1)
End If
rRow.Copy rTg
rTg.Resize(1, rRow.Columns.Count) = rRow.Value
Call EachSum(shtTmp)
End If
End If
Next
Call UserFormatSetting(sht) '서식을 main시트와 동일하게 적용하기
sht.Activate
MsgBox "작업이 완료되었습니다.", vbInformation
With Application
.ScreenUpdating = True
.Calculation = xlCalculationAutomatic
.EnableEvents = True
End With
End Sub
Function getSheet(SheetName As String, rX As Range)
Dim shtX As Worksheet
On Error Resume Next
Set getSheet = ThisWorkbook.Sheets(SheetName)
If Err.Number <> 0 Then
ThisWorkbook.Worksheets.Add After:=Sheets(Sheets.Count)
Set getSheet = ActiveSheet
getSheet.Name = SheetName
rX.Copy getSheet.Range("A1")
getSheet.Range("A3").Select
With ActiveWindow
.FreezePanes = True
.DisplayGridlines = False
End With
End If
On Error GoTo 0
End Function
Sub EachSum(sht As Worksheet)
Dim rSum As Range
Set rSum = sht.Cells(Rows.Count, 1).End(xlUp)
If rSum = "계" Then
Else
Set rSum = rSum.Offset(1)
rSum.Cells(1, 1).Value = "계"
End If
' 인원/금액 소계
rSum.Cells(1, 5).Formula = "=SUM(E3:E" & rSum.Row - 1 & ")"
rSum.Cells(1, 6).Formula = "=SUM(F3:F" & rSum.Row - 1 & ")"
Application.Goto rSum
End Sub
Sub UserFormatSetting(shtMain As Worksheet)
Dim sht As Worksheet
Dim lRow As Long, lCol As Long, lTemp As Long
Dim lMaxR As Long, lMaxC As Long
With shtMain.Range("A1")
lMaxR = .CurrentRegion.Rows.Count
lMaxC = .CurrentRegion.Columns.Count
End With
For Each sht In Worksheets
If shtMain.Name <> sht.Name Then
With sht.UsedRange
lRow = .Rows.Count
lCol = .Columns.Count
If lRow > lMaxR Then lRow = lMaxR
If lCol > lMaxC Then lCol = lMaxC
End With
If sht.Range("A1").MergeCells Then sht.Range("A1").UnMerge
Range(shtMain.Cells(1), shtMain.Cells(lRow, lCol)).Copy
sht.Range("A1").PasteSpecial xlPasteFormats
For lRow = 1 To sht.UsedRange.Rows.Count
lTemp = IIf(lRow > lMaxR, lMaxR - 1, lRow)
sht.Cells(lRow, 1).RowHeight = shtMain.Cells(lTemp, 1).Height
Next
For lCol = 1 To sht.UsedRange.Columns.Count
lTemp = IIf(lCol > lMaxC, lMaxC, lCol)
sht.Cells(2, lCol).ColumnWidth = shtMain.Cells(2, lTemp).ColumnWidth
Next
Application.Goto sht.Cells(Rows.Count, 1).End(xlUp)
End If
Next
End Sub
|
|
엑셀에 대한 질문과
답변을 올려주세요. 단, 취지에 맞지 않는 글은 운영자가 삭제합니다.
