| |
* 답변하시는 분들께 도움이 되도록 자신의 환경을 아래 항목 옆에 기재해 주세요.
- 엑셀 버전(95,97,2000,xp,2003,2007):
* 아래줄에 질문을 작성하세요 >>
아래 내용을 이용해서 예시파일을 정리하는데
비고쪽은 잘 병합이 되는데
대납금 쪽에서 제일 위에 금액으로 한번에 병합이 되는데
어떤것을 바꿔야하는지 궁금합니다
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
|
|
엑셀에 대한 질문과
답변을 올려주세요. 단, 취지에 맞지 않는 글은 운영자가 삭제합니다.
