| |
* 답변하시는 분들께 도움이 되도록 자신의 환경을 아래 항목 옆에 기재해 주세요.
- 엑셀 버전(95,97,2000,xp,2003,2007):
* 아래줄에 질문을 작성하세요 >>
안녕하세요
전에 한번 질문을 드렸었는데
제가 A열(업체명)기준으로 시트나누기 따로하고
C열(호수) 기준으로 K(대납금),L()비고)열 병합따로 하는데
두가지를 합쳐서 한번에 하는 방법이 있나 궁금해서 글 남깁니다
혹시 가능하시면 글 한번 부탁드립니다
==============[조남주님 글에 대한 답변입니다]==============
첨부화일 참고하세요....
Option Explicit
Sub Split_sheet_by_name()
Dim wst As Worksheet, wstAct As Worksheet
Dim rRow As Range, rData As Range
Dim wstNew As Worksheet
Dim vKey
Dim iX As Integer
Dim oList As Object
Dim oDic As Object
Set oDic = CreateObject("Scripting.Dictionary")
Set wstAct = ActiveSheet
Application.ScreenUpdating = False
'데이타 범위
Set rData = wstAct.Range("A1").CurrentRegion
Set rData = rData.Offset(1).Resize(rData.Rows.Count - 1)
For Each rRow In rData.Rows
vKey = rRow.Cells(1)
If oDic.Exists(vKey) Then
Set oDic.Item(vKey) = Union(oDic.Item(vKey), rRow)
Else
oDic.Add vKey, rRow
End If
Next
Application.DisplayAlerts = False
For Each vKey In oDic.Keys
'기존시트 삭제
On Error Resume Next: Worksheets(vKey).Delete: On Error GoTo 0
Set wstNew = Worksheets.Add(After:=Worksheets(Sheets.Count))
wstNew.Name = vKey
wstAct.Rows(1).Copy wstNew.Cells(1): oDic.Item(vKey).Copy wstNew.Cells(2, 1)
wstNew.Range("A1").CurrentRegion.Columns.AutoFit
Call UserMerge(wstNew)
Next
Application.DisplayAlerts = True
End Sub
Sub UserMerge(sht As Worksheet)
'Dim sht As Worksheet
Dim lRow As Long
Dim vTemp
Dim rUnion As Range
Dim rX As Range, rY As Range, rZ As Range
For lRow = 2 To sht.Cells(Rows.Count, 3).End(xlUp).Row
Set rX = sht.Cells(lRow, 3) '
Set rY = sht.Cells(lRow, 11)
Set rZ = sht.Cells(lRow, 12)
If rX = rX.Offset(1) Then
If rY.MergeArea.Cells(1) = "" Then
Set rUnion = userUnion(rUnion, rY.Resize(2))
If rZ.MergeArea.Cells(1) = rZ.Offset(1) Then
Call Exec_Merge(rZ.Resize(2))
End If
Else
If rY.Offset(1) = "" Then
Set rUnion = userUnion(rUnion, rY.Resize(2))
If rZ.MergeArea.Cells(1) = rZ.Offset(1) Then
Call Exec_Merge(rZ.Resize(2))
End If
Else
Call Exec_Merge(rUnion)
End If
End If
Else
Call Exec_Merge(rUnion)
End If
Next
End Sub
Function userUnion(rX As Range, rY As Range)
If rX Is Nothing Then
Set userUnion = rY
Else
Set userUnion = Union(rX, rY)
End If
End Function
Sub Exec_Merge(rX As Range)
If Not rX Is Nothing Then
rX.Merge
Set rX = Nothing
End If
End Sub |
|
엑셀에 대한 질문과
답변을 올려주세요. 단, 취지에 맞지 않는 글은 운영자가 삭제합니다.
