아주 재미난 로직을 소개합니다
현재값을 바탕으로 미래를 예측하는 시나리오에 적합한 로직입니다
피벗테이블을 사용한
지역별, 부서별 합을 구하는 방법은 아주 훌륭한 기능인데요
부서별 인원을 구한 이후에
만들어진 결과를 가지고 특정 부서의 인원을 늘리고자 한다면
그리고 그 이후의 총 인원 변화를 예상하려 한다면
피벗의 경우는 원본 데이터의 일부를 수정 한 다음 피벗 갱신 을 해야합니다
어디를 수정할지 그리고 갱신은 언제 누를 지 답답합니다
해서...
결과물을 피벗과 같은 형태로 만들되 , 부분합 부분만 수식을 만든 다음
특정 부서의 인원(부분합 부분이 아니겠습니다)을 변경할 때 총 인원이 자동으로 늘어나는
그런 로직입니다.
로직의 요약은 이렇습니다
실제 데이터 원본이 존재합니다.
조건별로 부분합이 있는 집계를 구합니다.
만들어진 결과는 일테면 지역별 성별 인원수 인 경우는
지역별 소계(부분합)는 존재합니다 ----------------------------- 수식
지역의 성별 인원은 피벗 처럼 값으로 결과를 만들어냅니다 ---------- 값
만들어진 결과 중에서 부분합 부분은 수식이어야 하고
"값" 부분을 변경하면 "수식" 부분이 자동 계산되어 전체의 값 변동을 즉시 알수 있도록 함이 목적입니다.
데이터 원본은 건드리지 않고 특정 부서의 인원을 바꾸면 전체 인원이 얼마나 되나
를 볼수 있는 로직입니다. 기대치 확보나, 시뮬레이션 가동에 유용합니다.
0123456789
주요 코드입니다
Sub Excute_Expect()' === 모듈 시작
' CodeBy [ 오즈맨 ] , Date : 2015-04-19
Dim MyySheet As Worksheet
Set MyySheet = ThisWorkbook.Sheets("DATA")
Call Range_Clear
MsgBox "Ready~~"
Call PivotSumUP(RngSource:=MyySheet.Range("$C$5").CurrentRegion, AnswerRng:=MyySheet.Range("P5"), SubTotal_At_Top:=False)
Call PivotSumUP(RngSource:=MyySheet.Range("$C$5").CurrentRegion, AnswerRng:=MyySheet.Range("AC5"), SubTotal_At_Top:=True)
End Sub ' ___ 모듈 종료
Sub PivotSumUP(RngSource As Range, AnswerRng As Range, SubTotal_At_Top As Boolean)' === 모듈 시작
' CodeBy [ 오즈맨 ] , Date : 2015-04-19
Dim ii As Double
Dim jj As Double
Dim Work_Sheet As Worksheet
Dim Sort_Sheet As Worksheet
Dim Uniq_Count As Double
Dim Rows_Count As Double ' 원본의 ROWS
Dim Found__Row As Double ' 찾는 INDEX NUMBER
Dim Found_Colm As Double
Dim MySource As Variant ' 피벗의 원본
Dim Uniq_Value As New Collection ' ANSW 용 UNIQ , Fixed 문자열
Dim FixedValue As Variant
Dim Sort_Value As Variant ' 쏘트용 값 INSERT -> Uniq_Value
Dim EditRange As Range
Dim FixString As String
Dim tmpString As String ' UNIQ 만들때 사용하는 임시변수
Dim MyAnswers As Variant ' 최종 결과
Dim tmp_Array As Variant ' SORT 이후를 ANSW 로 보낼 임시변수
Dim Sort_Range As Range
Dim Has_Gross_Total As Boolean
Dim Top_Gross_Total As Boolean
Has_Gross_Total = True
Top_Gross_Total = False ' True
Dim Gross_total_Top As String
FixString = "_|_"
Application.ScreenUpdating = False
Set Work_Sheet = RngSource.Parent
Set Sort_Sheet = Sheets("sheet3") ' Worksheets.Add
'''Work_Sheet.Activate
MySource = RngSource.Value
Rows_Count = UBound(MySource, 1)
On Error Resume Next
ReDim FixedValue(1 To Rows_Count) As Variant
ii = 1
For jj = 2 To 4
tmpString = tmpString & FixString & MySource(ii, jj)
Next
FixedValue(ii) = tmpString
Uniq_Value.Add tmpString, tmpString
For ii = 2 To Rows_Count
tmpString = ""
For jj = 2 To 4
tmpString = tmpString & FixString & MySource(ii, jj)
Uniq_Value.Add tmpString, tmpString
Next
FixedValue(ii) = tmpString
Next
Uniq_Count = Uniq_Value.Count
ReDim Sort_Value(1 To Uniq_Count, 1 To 2)
For ii = 1 To Uniq_Count
Sort_Value(ii, 1) = Uniq_Value(ii)
Sort_Value(ii, 2) = Uniq_Value(ii) & "Z"
Next
Set Sort_Range = Sort_Sheet.Range("A1")
Sort_Range.Resize(Uniq_Count, 2).EntireColumn.ClearContents
Sort_Range.Resize(Uniq_Count, 2) = Sort_Value
If Has_Gross_Total = True Then
If Top_Gross_Total = True Then
Gross_total_Top = "Top"
Else
Gross_total_Top = "Bottom"
End If
ElseIf Has_Gross_Total = False Then
Gross_total_Top = "No"
End If
If Gross_total_Top = "Top" Then
Sort_Range.Offset(Uniq_Count, 0).Resize(1, 2) = "'"
Uniq_Count = Uniq_Count + 1
End If
If SubTotal_At_Top = True Then
Sort_Range.Resize(Uniq_Count, 2).SortSpecial key1:=Sort_Range(1, 1), Order1:=xlAscending, Header:=xlYes
Else
Sort_Range.Resize(Uniq_Count, 2).SortSpecial key1:=Sort_Range(1, 2), Order1:=xlAscending, Header:=xlYes
End If
If Gross_total_Top = "Bottom" Then
Sort_Range.Offset(Uniq_Count, 0).Resize(1, 2) = "'"
Uniq_Count = Uniq_Count + 1
End If
Sort_Value = Sort_Range.Resize(Uniq_Count, 1).Value
ReDim MyAnswers(1 To Uniq_Count, 1 To 5)
Set Uniq_Value = Nothing
For ii = 1 To Uniq_Count
Uniq_Value.Add ii, Sort_Value(ii, 1)
Next
Uniq_Value.Add ii, ""
For ii = 1 To Uniq_Count
Found_Colm = InStrRev(Sort_Value(ii, 1), FixString) - 1
If Found_Colm >= 0 Then
tmpString = Left(Sort_Value(ii, 1), Found_Colm)
Found__Row = Uniq_Value(tmpString)
' 누적
MyAnswers(Found__Row, 4) = MyAnswers(Found__Row, 4) & "+R[" & ii - Found__Row & "]C"
MyAnswers(Found__Row, 5) = MyAnswers(Found__Row, 5) & "+R[" & ii - Found__Row & "]C"
End If
tmp_Array = Split(Sort_Value(ii, 1), FixString)
For jj = 1 To 3
MyAnswers(ii, jj) = tmp_Array(jj)
Next
Next
For ii = 2 To Rows_Count
Found__Row = Uniq_Value(FixedValue(ii))
' 인원수
MyAnswers(Found__Row, 4) = MyAnswers(Found__Row, 4) + 1
' 인건비
MyAnswers(Found__Row, 5) = MyAnswers(Found__Row, 5) + MySource(ii, 5)
Next
For ii = 2 To Uniq_Count
If Left(MyAnswers(ii, 4), 1) = "+" Then
MyAnswers(ii, 4) = "=" & Mid(MyAnswers(ii, 4), 2)
MyAnswers(ii, 5) = "=" & Mid(MyAnswers(ii, 5), 2)
End If
Next
For ii = Uniq_Count To 2 Step -1
For jj = 1 To 3
If MyAnswers(ii, jj) = MyAnswers(ii - 1, jj) Then
MyAnswers(ii, jj) = Empty
End If
Next
Next
If Gross_total_Top = "Top" Then
MyAnswers(2, 1) = "총계"
ElseIf Gross_total_Top = "Bottom" Then
MyAnswers(Uniq_Count, 1) = "총계"
Else
End If
MyAnswers(1, 4) = "인원"
MyAnswers(1, 5) = "인건비"
With AnswerRng.Resize(Uniq_Count, 5)
.EntireColumn.ClearContents
.EntireColumn.Interior.ColorIndex = xlNone
.Formula = MyAnswers
.Interior.ColorIndex = 15
.NumberFormat = "#,#"
End With
Set EditRange = AnswerRng(1, 4).Resize(Uniq_Count, 2).SpecialCells(xlCellTypeConstants, xlNumbers)
EditRange.Interior.ColorIndex = xlNone
Application.ScreenUpdating = True
Application.DisplayAlerts = False
Application.DisplayAlerts = True
End Sub ' ___ 모듈 종료
플래시 파일이 잘 안 보이면 그냥 다운로드 하세요
If cannot flash file... download movie...
PivotFormula4Simm.exe예제 데이터와 코드가 있는 파일입니다.
here sample data and vba code...
PivotFormulaNew.xls'기 타' 카테고리의 다른 글
| vba 를 사용해서 mdb 생성에 필요한 데이터형식 인수 (0) | 2015.01.06 |
|---|---|
| 한반도에 퍼지는 역행침식 현상 (1) | 2011.02.03 |
| 2010-08/17 방송예정이던 PD수첩 보도자료 전문 (0) | 2010.08.18 |
| lrc파일 시간 편집기 (가사파일 시간 조정) (5) | 2009.03.11 |
| 버철박스 VirtualBox 에서 인터넷 Internet 이 안되면 (3) | 2008.12.11 |
| 법에 의한 또는 변호사 선임시 일반적인 절차 (0) | 2008.06.23 |
