|
공통모듈(xla 가 xlam으로 바뀌였나보네) : GS_BP_Common
모듈명 : m_API
Option Explicit
'
' 저장 프로시저 실행, 또는 강제 조회를 위한 데이터 Refresh
'
Public Sub Refresh_Sheets(SheetNameList As String)
' ======================================================================
' 변수명 설명
' ----------------------------------------------------------------------
'
' SheetNameList 콤마로 구분된 Refresh할 대상 워크시트 리스트
'
' ======================================================================
Dim arrSheet As Variant
Dim i As Integer
Dim sht As Worksheet
arrSheet = Split(SheetNameList, ",")
For i = 0 To UBound(arrSheet)
Set sht = ActiveWorkbook.Worksheets(arrSheet(i))
Call Refresh_Data(sht)
Next i
End Sub
'=======================================================
' Data 새로고침
' 보고서 명, 시트명, wait flag
'=======================================================
Public Sub Refresh_Data(sht As Worksheet)
' ======================================================================
' 변수명 설명
' ----------------------------------------------------------------------
'
' TargetWorksheet 작업대상 워크시트, 지정하지 않으면 모든 시트
'
' ======================================================================
Dim addin As COMAddIn
Dim mxmodule As Object
Set addin = Application.COMAddIns.Item("ExcelModule.AddinModule")
Set mxmodule = addin.Object
'book 명, sheet 명, wait flag (true 새로고침 종료시 까지 기다림, false 기다리지 않음)
mxmodule.RefreshData sht.Parent.Name, sht.Name, True
Set mxmodule = Nothing
Set addin = Nothing
End Sub
'=======================================================
' Dataset Refresh
' Dataset 명 사용
'=======================================================
Public Sub Refresh_DataSet(strDataSetName As String)
' ======================================================================
' 변수명 설명
' ----------------------------------------------------------------------
'
' DataSetName Refresh 할 데이터 셋 명
'
' ======================================================================
Dim addin As COMAddIn
Dim mxmodule As Object
Set addin = Application.COMAddIns.Item("ExcelModule.AddinModule")
Set mxmodule = addin.Object
' dataset 명, 비동기 작업 (결과 기다리지 않음, 완료 이후 작업 필요시 OnRefreshAfter event 사용)
mxmodule.xapi.RefreshDataSet strDataSetName
Set mxmodule = Nothing
Set addin = Nothing
End Sub
'=======================================================
' Select 쿼리 실행 후 특정 시트에 출력 하는 예제
' lastrecordset 은 adorecordset 입니다.
' ADO Recordset 을 사용한 응용이 가능합니다.
'=======================================================
Public Sub ExecuteSQL()
Dim addin As COMAddIn
Dim mxmodule As Object
Dim rs As Object
Set addin = Application.COMAddIns.Item("ExcelModule.AddinModule")
Set mxmodule = addin.Object
'execute (dbmscode, sqltext, [optional] maxrecord)
mxmodule.xapi.Execute "mtxrpty", "select * from mtx_user"
If mxmodule.xapi.LastErrorCode <> 0 Then
Call ShowMessage(strPrompt:="쿼리 실행 오류 " & mxmodule.xapi.LastErrorMessage, Button:=vbExclamation, strTitle:="오류")
'MsgBox "쿼리 실행 오류" & mxmodule.xapi.LastErrorMessage
Else
Range("a1").CopyFromRecordset mxmodule.xapi.LastRecordset
End If
Set rs = Nothing
Set mxmodule = Nothing
Set addin = Nothing
End Sub
'=======================================================
' Insert/update/delete 쿼리 실행 예제
'=======================================================
Public Sub ExecuteDML()
Dim addin As COMAddIn
Dim mxmodule As Object
Set addin = Application.COMAddIns.Item("ExcelModule.AddinModule")
Set mxmodule = addin.Object
'executeDML (dbmscode, sqltext)
mxmodule.xapi.ExecuteDML "mtxrpty", "insert into mtx_ftp values('1112','user',100, 'pw','path','attr1')"
If mxmodule.xapi.LastErrorCode <> 0 Then
Call ShowMessage(strPrompt:="쿼리 실행 오류 " & mxmodule.xapi.LastErrorMessage, Button:=vbExclamation, strTitle:="오류")
' MsgBox "쿼리 실행 오류 " & mxmodule.xapi.LastErrorMessage
End If
Set mxmodule = Nothing
Set addin = Nothing
End Sub
'=======================================================
' MessageSend 예제
' web page 로 메세지 전달 에 사용
'=======================================================
Public Sub MessageSendTest()
Dim addin As COMAddIn
Dim mxmodule As Object
Set addin = Application.COMAddIns.Item("ExcelModule.AddinModule")
Set mxmodule = addin.Object
'‘message id, param
mxmodule.xapi.MessageSend 10, "mtxrpty"
Set mxmodule = Nothing
Set addin = Nothing
End Sub
'Viewe.jsp web page 에 MessageSend 수신 처리가 되어 있어야 합니다.
'
'Viewer.jsp
'… 중략
'//=========================================================================================================
' /** VBA 에서 메세지 전송시 발생합니다. (XAPI.MessageSend 사용) * args.Code : message code : 숫자 * args.Message : 메세지 : 문자
'**/
' //=========================================================================================================
'var [안내]태그제한으로등록되지않습니다-OnMessage = function (args) {
' //alert(args.Code + args.Message);
' }
'=============================================================
' dataset Refresh 되기 전에 발생합니다.
' args.Dataset.Code
'=============================================================
Public Function OnRefreshBefore(sender As Object, args As Object)
' debug.Print args.datasetname
'취소에 사용
'args.cancel = True
End Function
'=============================================================
' dataset Refresh 된 후에 발생합니다.
' args.Dataset.Code
'=============================================================
Public Function OnRefreshAfter(sender As Object, args As Object)
' debug.Print args.datasetname
'dataset DS1 이 refresh 완료 될경우 DS2 를 refresh 하는 예제
If args.datasetname = "DS1" Then
sender.xapi.RefreshDataSet "DS2"
End If
End Function
'=======================================================
' Dataset 생성 예제
'=======================================================
Public Sub RefreshDatasetTest()
Dim addin As COMAddIn
Dim mxmodule As Object
Dim ds As Object
Set addin = Application.COMAddIns.Item("ExcelModule.AddinModule")
Set mxmodule = addin.Object
' dataset 명, 비동기 작업 (결과 기다리지 않음, 완료 이후 작업 필요시 OnRefreshAfter event 사용)
Set ds = mxmodule.viewmodel.activebook.createdataset("ds1", "ds1")
ds.sourcesql = "select * from mtx_user"
mxmodule.viewmodel.activebook.AddDataset ds
Set mxmodule = Nothing
Set addin = Nothing
End Sub
모듈명 : m_Design
Option Explicit
Public Sub Auto_Open()
Call Make_Formula_Tracer
'Call Make_PageLayout
Call Make_PasteText
Call Make_Design_Menu
Debug.Print "Auto_Open"
End Sub
Public Sub Make_Design_Menu()
Dim cbar As CommandBar
Dim cPopup As CommandBarPopup
Set cbar = Application.CommandBars("Cell")
Set cPopup = cbar.Controls.Add(Type:=msoControlPopup, Temporary:=True)
cPopup.Caption = "디자인"
Call Make_Design_Button(cPopup, "기본", "Design_Default")
Call Make_Design_Button(cPopup, "헤더", "Design_TopHeader")
Call Make_Design_Button(cPopup, "왼쪽 헤더", "Design_LeftHeader")
Call Make_Design_Button(cPopup, "헤더(실적)", "Design_TopHeader_ACT")
Call Make_Design_Button(cPopup, "헤더(계획)", "Design_TopHeader_PLAN")
' Call Make_Design_Button(cPopup, "데이터(자동 교차 색상)", "Design_Data")
Call Make_Design_Button(cPopup, "집계(SUM함수등)", "Design_Agg")
Call Make_Design_Button(cPopup, "집계(SubTotal)", "Design_SubTotal")
Call Make_Design_Button(cPopup, "집계(Total)", "Design_Total")
Call Make_Design_Button(cPopup, "계산(업무 계산 수식)", "Design_Calc")
Call Make_Design_Button(cPopup, "테두리(가늘게)", "Design_Border")
Call Make_Design_Button(cPopup, "테두리(두껍게)", "Design_Border_T")
Call Clear_Style
Call Style_Merge
Application.OnKey Key:="+^R", Procedure:="Get_Target_Address"
End Sub
Public Sub Make_Design_Button(cPopup As CommandBarPopup, strCaption As String, strAction As String)
Dim cBtn As CommandBarButton
Set cBtn = cPopup.Controls.Add(Type:=msoControlButton)
With cBtn
.Caption = strCaption
.OnAction = strAction
End With
End Sub
Public Sub Design_Default()
Dim rng As Range
Dim rngSel As Range
Set rngSel = Selection
rngSel.Style = "DEFAULT"
End Sub
Public Sub Design_TopHeader()
Dim rng As Range
Dim rngSel As Range
Set rngSel = Selection
rngSel.Style = "TOP_HEADER"
With rngSel.Borders(xlInsideVertical)
.LineStyle = xlContinuous
.ThemeColor = 1
.TintAndShade = -0.349986266670736
.Weight = xlThin
End With
End Sub
Public Sub Design_LeftHeader()
Dim rng As Range
Dim rngSel As Range
Set rngSel = Selection
rngSel.Style = "LEFT_HEADER"
' With rngSel.Borders(xlInsideVertical)
' .LineStyle = xlContinuous
' .Color = -9343379
' .TintAndShade = 0
' .Weight = xlThin
' End With
'
' With rngSel.Borders(xlInsideHorizontal)
' .LineStyle = xlContinuous
' .ThemeColor = 1
' .TintAndShade = -0.349986266670736
' .Weight = xlThin
' End With
End Sub
Public Sub Design_TopHeader_ACT()
Dim rng As Range
Dim rngSel As Range
Set rngSel = Selection
rngSel.Style = "TOP_HEADER_ACTUAL"
End Sub
Public Sub Design_TopHeader_PLAN()
Dim rng As Range
Dim rngSel As Range
Set rngSel = Selection
rngSel.Style = "TOP_HEADER_PLAN"
End Sub
Public Sub Design_Data()
Dim rng As Range
Dim rng2 As Range
Dim rngSel As Range
Dim rngF As Range
Dim bOddEven As Boolean
Application.ScreenUpdating = False
Set rngSel = Selection
' 테두리
With rngSel.Borders
.LineStyle = xlContinuous
.Color = -9343379
.TintAndShade = 0
.Weight = xlThin
End With
With rngSel.Borders(xlInsideHorizontal)
.LineStyle = xlContinuous
.ThemeColor = 1
.TintAndShade = -0.349986266670736
.Weight = xlThin
End With
' 색상 제고
rngSel.Interior.Pattern = xlNone
' 교차된 라인에 데이터 스타일 적용
For Each rng In rngSel.Areas
Set rngF = rng.Resize(, 1)
bOddEven = True
For Each rng2 In rngF
bOddEven = Not bOddEven
If bOddEven Then
rng2.Resize(, rng.Columns.Count).Style = "DATA"
End If
Next rng2
Next rng
Application.ScreenUpdating = True
End Sub
Public Sub Design_SubTotal()
Dim rng As Range
Dim rngSel As Range
Set rngSel = Selection
rngSel.Style = "SUB_TOTAL"
End Sub
Public Sub Design_Total()
Dim rng As Range
Dim rngSel As Range
Set rngSel = Selection
rngSel.Style = "TOTAL"
End Sub
Public Sub Design_Agg()
Selection.Style = "AGGREGATION"
End Sub
Public Sub Design_Calc()
Selection.Style = "CALCULATE"
End Sub
Public Sub Design_Border()
With Selection.Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.Color = -9343379
.TintAndShade = 0
.Weight = xlThin
End With
With Selection.Borders(xlEdgeTop)
.LineStyle = xlContinuous
.Color = -9343379
.TintAndShade = 0
.Weight = xlThin
End With
With Selection.Borders(xlEdgeRight)
.LineStyle = xlContinuous
.Color = -9343379
.TintAndShade = 0
.Weight = xlThin
End With
With Selection.Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.Color = -9343379
.TintAndShade = 0
.Weight = xlThin
End With
End Sub
Public Sub Design_Border_T()
With Selection.Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.Color = -9343379
.TintAndShade = 0
.Weight = xlMedium
End With
With Selection.Borders(xlEdgeTop)
.LineStyle = xlContinuous
.Color = -9343379
.TintAndShade = 0
.Weight = xlMedium
End With
With Selection.Borders(xlEdgeRight)
.LineStyle = xlContinuous
.Color = -9343379
.TintAndShade = 0
.Weight = xlMedium
End With
With Selection.Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.Color = -9343379
.TintAndShade = 0
.Weight = xlMedium
End With
' With Selection.Borders(xlInsideVertical)
' .LineStyle = xlContinuous
' .Color = -9343379
' .TintAndShade = 0
' .Weight = xlThin
' End With
End Sub
모듈명 : m_FormulaTracer
Option Explicit
'
' 셀 수식 추적 메뉴 생성
'
Public Sub Make_Formula_Tracer()
Dim cBarCell As CommandBar
Dim cBarFormula As CommandBar
Dim cPopup As CommandBarPopup
Set cBarCell = Application.CommandBars("Cell")
cBarCell.Reset
Set cBarFormula = Application.CommandBars("Formula Auditing")
Set cPopup = cBarCell.Controls.Add(Type:=msoControlPopup, Temporary:=True)
cPopup.Caption = "셀 수식 추적"
Call Make_Tracer_Button(cPopup, cBarFormula.Controls("참조되는 셀 추적(&T)"))
Call Make_Tracer_Button(cPopup, cBarFormula.Controls("참조되는 셀 연결선 제거(&R)"))
Call Make_Tracer_Button(cPopup, cBarFormula.Controls("참조하는 셀 추적(&D)"))
Call Make_Tracer_Button(cPopup, cBarFormula.Controls("참조하는 셀 연결선 제거(&R)"))
Call Make_Tracer_Button(cPopup, cBarFormula.Controls("연결선 모두 제거(&A)"))
End Sub
Public Sub Make_Tracer_Button(cPopup As CommandBarPopup, ctl As CommandBarControl)
Dim cBtn As CommandBarButton
Set cBtn = cPopup.Controls.Add(Type:=msoControlButton, ID:=ctl.ID)
End Sub
Public Sub AAAAADFDSAGFAGFDA()
Dim cmdbar As CommandBar
Dim cmdctl As CommandBarControl
Dim i As Integer
For Each cmdbar In Application.CommandBars
For Each cmdctl In cmdbar.Controls
i = i + 1
Range("a1").Offset(i).Resize(, 3).Value = Array(cmdbar.Name, cmdctl.Caption, cmdctl.ID)
Next cmdctl
Next cmdbar
End Sub
모듈명 : m_Functions
Option Explicit
Option Compare Text
'
' Message
'
Public Function ShowMessage(strPrompt As String, Button As VbMsgBoxStyle, strTitle As String) As VbMsgBoxResult
Dim isSim As Boolean
' 시뮬레이션 실행중이면 메시지 출력 안함
isSim = IsSimulationVersion
If isSim Then
Else
ShowMessage = MsgBox(Prompt:=strPrompt, Buttons:=Button, Title:=strTitle)
End If
End Function
'
' 시뮬레이션 실행중 상태 반환
'
Public Function IsSimulationVersion() As Boolean
On Error Resume Next
IsSimulationVersion = False
IsSimulationVersion = ActiveWorkbook.Names("SIMULATION_RUNNING_STATUS").RefersToRange.Value
Err.Clear
End Function
'
' 버전 상태 체크
'
Public Function Get_Version_Status() As Boolean
On Error Resume Next
Get_Version_Status = False
Get_Version_Status = (UCase(ActiveWorkbook.Names("VS_PLAN_VERSION_STATUS").RefersToRange.Value) = "OPEN")
Err.Clear
End Function
'
' 뷰 시트인지 확인
'
Public Function IsView(sht) As Boolean
Dim rngDef As Range
On Error Resume Next
Set rngDef = sht.Names("_Def_Input_Col_").RefersToRange
IsView = (Err.Number = 0)
Err.Clear
End Function
'
' 입력된 워크시트 이름을 가진 시트 개체 반환
'
Public Function Get_WorkSheet(strSheetName As String) As Worksheet
Dim arrSheet As Variant
On Error GoTo NotExists
arrSheet = Split(strSheetName, "[|]")
' 지정된 이름의 시트를 반환
Set Get_WorkSheet = ActiveWorkbook.Worksheets(arrSheet(0))
Exit Function
NotExists:
' 지정된 이름의 시트가 없음
Set Get_WorkSheet = Nothing
End Function
'
' 대상 범위의 워크시트를 지정한 워크시르로 변경
'
Public Function Change_ParentSheet(rngTarget As Range, shtToSheet As Worksheet) As Range
Dim rng As Range
Dim rngResult As Range
' 첫 번재 영역 할당
Set rngResult = shtToSheet.Range(rngTarget.Areas(1).Address)
For Each rng In rngTarget.Areas
' 시트 변경
Set rngResult = Application.Union(rngResult, shtToSheet.Range(rng.Address))
Next rng
' 결과 리턴
Set Change_ParentSheet = rngResult
End Function
'
' 빈 셀, 수식 또는 상수로 지정된 셀들 추출
'
Public Function Get_SpecialCells(rngTarget As Range, CellType As XlCellType, Optional CellValue As XlSpecialCellsValue) As Range
Dim rngRslt As Range
Dim rngC As Range
Dim rngF As Range
On Error GoTo NotFound
If rngTarget.Cells.Count = 1 Then
' 셀의 갯수가 한 개인 경우
Select Case CellType
Case xlCellTypeBlanks ' 빈 셀
If IsEmpty(rngTarget.Value) Then
Set rngRslt = rngTarget
End If
Case Else
If CellType And xlCellTypeConstants Then ' 상수
If rngTarget.HasFormula Then
Else
Set rngC = Get_SingleCell(rngTarget, CellValue)
End If
End If
If CellType And xlCellTypeFormulas Then ' 수식
If rngTarget.HasFormula Then
Set rngF = Get_SingleCell(rngTarget, CellValue)
End If
End If
Set rngRslt = Union_Range(rngC, rngF)
End Select
Else
' 셀의 갯수가 2개 이상인 경우
Select Case CellType
Case xlCellTypeBlanks ' 빈 셀
Set rngRslt = rngTarget.SpecialCells(Type:=xlCellTypeBlanks)
Case Else
If CellType And xlCellTypeConstants Then ' 상수
Set rngC = Get_SpecialCells_Exec(rngTarget, xlCellTypeConstants, CellValue)
End If
If CellType And xlCellTypeFormulas Then ' 수식
'Set rngC = Get_SpecialCells_Exec(rngTarget, xlCellTypeFormulas, CellValue)
Set rngF = Get_SpecialCells_Exec(rngTarget, xlCellTypeFormulas, CellValue)
End If
Set rngRslt = Union_Range(rngC, rngF)
End Select
End If
Set Get_SpecialCells = rngRslt
Exit Function
NotFound:
Set Get_SpecialCells = Nothing
End Function
'
' 빈 셀, 수식 또는 상수로 지정된 셀 추출 실행
'
Public Function Get_SpecialCells_Exec(rng As Range, CellType As XlCellType, Optional CellValue As XlSpecialCellsValue) As Range
On Error GoTo NotFound
Set Get_SpecialCells_Exec = rng.SpecialCells(Type:=CellType, Value:=CellValue)
Exit Function
NotFound:
Set Get_SpecialCells_Exec = Nothing
End Function
'
' 단일 셀에 대한 특정 셀 대상 여부 계산
'
Public Function Get_SingleCell(rngTarget As Range, CellValue As XlSpecialCellsValue) As Range
Dim rngRslt As Range
Dim rngErr As Range
Dim rngLogical As Range
Dim rngNumber As Range
Dim rngText As Range
If CellValue And xlErrors Then
If Application.WorksheetFunction.IsError(rngTarget.Value) Then
Set rngErr = rngTarget
End If
End If
If CellValue And xlLogical Then
If Application.WorksheetFunction.IsLogical(rngTarget.Value) Then
Set rngLogical = rngTarget
End If
End If
If CellValue And xlNumbers Then
If Application.WorksheetFunction.IsNumber(rngTarget.Value) Then
Set rngNumber = rngTarget
End If
End If
If CellValue And xlTextValues Then
If Application.WorksheetFunction.IsText(rngTarget.Value) Then
Set rngText = rngTarget
End If
End If
Set rngRslt = Union_Range(rngErr, rngLogical)
Set rngRslt = Union_Range(rngRslt, rngNumber)
Set rngRslt = Union_Range(rngRslt, rngText)
Set Get_SingleCell = rngRslt
End Function
'
' 범위 union
'
Public Function Union_Range(rng1 As Range, rng2 As Range) As Range
Dim rngRslt As Range
Set rngRslt = Nothing
If rng1 Is Nothing Then
If rng2 Is Nothing Then
Else
Set rngRslt = rng2
End If
Else
If rng2 Is Nothing Then
Set rngRslt = rng1
Else
Set rngRslt = Union(rng1, rng2)
End If
End If
Set Union_Range = rngRslt
End Function
'
' 이름 정의된 범위 가져오기
'
Public Function Get_NamedRange(strName As String, Optional sht As Worksheet) As Range
On Error GoTo GetRangeErr
If sht Is Nothing Then
Set Get_NamedRange = ActiveWorkbook.Names(strName).RefersToRange
Else
Set Get_NamedRange = sht.Names(strName).RefersToRange
End If
Exit Function
GetRangeErr:
Set Get_NamedRange = Nothing
Err.Clear
End Function
'
' 기준셀로부터 전체 행 크기로 크기 반환(머리글 행 제외)
'
Public Function Get_ResizeBaseRange(rngBase As Range) As Range
Dim rngCurrent As Range
Dim rngResult As Range
Dim rngTemp As Range
Set rngCurrent = rngBase.CurrentRegion.Offset(1)
If rngCurrent.Rows.Count > 1 Then
Set rngTemp = rngBase.Resize(rngCurrent.Rows.Count - 1).Offset(1)
Set rngResult = Application.Intersect(rngBase.CurrentRegion, rngTemp)
Else
Set rngResult = Nothing
End If
Set Get_ResizeBaseRange = rngResult
End Function
'
' 피벗테이블의 비어있음 항목 제거
'
Public Sub Exclude_Empty(pvt As PivotTable, strField As String)
Dim pvtItem As PivotItem
Dim fld As PivotField
On Error GoTo Exit_Exclude
Set fld = pvt.PivotFields(strField)
Set pvtItem = fld.PivotItems("(blank)")
pvtItem.Visible = False
Exit_Exclude:
Err.Clear
End Sub
'
' 적용 대상에 정의한 범위에 대한 영역 계산
'
Public Function Get_FormulaRange_Unit(strFormula As String, sht As Worksheet) As Range
Dim arrRange As Variant
Dim rngRslt As Range
Dim rng As Range
Dim i As Integer
On Error GoTo Get_FormulaRange_Error
arrRange = Split(strFormula, ",")
For i = 0 To UBound(arrRange)
Set rng = Get_FormulaRange(CStr(arrRange(i)), sht)
Set rngRslt = Union_Range(rngRslt, rng)
Next i
Set Get_FormulaRange_Unit = rngRslt
Exit Function
Get_FormulaRange_Error:
Set Get_FormulaRange_Unit = Nothing
End Function
'
' 적용 대상에 정의한 범위에 대한 영역 계산
'
Public Function Get_FormulaRange(strFormula As String, sht As Worksheet) As Range
On Error GoTo Get_FormulaRange_Error
If InStr(strFormula, "!") > 0 Then
Set Get_FormulaRange = Range(strFormula)
Else
Set Get_FormulaRange = sht.Range(strFormula)
End If
Exit Function
Get_FormulaRange_Error:
Set Get_FormulaRange = Nothing
End Function
'
' 두 개의 범위를 서로 치환함
'
Public Function Swap_Range(rngColumn As Range, rngRow As Range) As Boolean
Dim rngSwap As Range
On Error GoTo SwapErr
Set rngSwap = rngColumn
Set rngColumn = rngRow
Set rngRow = rngSwap
Swap_Range = True
Exit Function
SwapErr:
Swap_Range = False
End Function
'
' 범위 계산
' 지정된 범위의 수식 길이가 255자를 넘는 경우 한꺼번에 범위 반환이 안됨
' 이 문제를 해결하기위해 루프 처리
'
Public Function Get_Range(rngSource As Range, Optional sht As Worksheet) As Range
Dim rng As Range
Dim arrRange As Variant
Dim i As Integer
arrRange = Split(rngSource.Formula, ",")
If sht Is Nothing Then
Set rng = Range(arrRange(0))
For i = 1 To UBound(arrRange)
Set rng = Union(rng, Range(arrRange(i)))
Next i
Else
Set rng = sht.Range(arrRange(0))
For i = 1 To UBound(arrRange)
Set rng = Union(rng, sht.Range(arrRange(i)))
Next i
End If
Set Get_Range = rng
End Function
'
' 범위 계산
' 문자열을 셀 주소로 변환
'
Public Function Get_String2Range(shtView As Worksheet, strAddress As String) As Range
On Error GoTo Err_Convert2Range
Set Get_String2Range = shtView.Range(strAddress)
Exit Function
Err_Convert2Range:
Set Get_String2Range = Nothing
End Function
'
' 범위 계산
' 자동 수식 확장 범위 셀 주소로 변환
'
Public Function Get_AutoExpandRange(shtView As Worksheet, rng As Range) As Range
Dim rngBase As Range
Dim rngFormulaSource As Range
Dim rngExpand As Range
Dim rngLimit As Range
Dim rngResize As Range
Dim rngMove As Range
Set Get_AutoExpandRange = Nothing
If IsEmpty(rng.Value) Then
' 수식의 원본 범위 영역이 빈 셀임
' 범위를 자동으로 확장할 수 없음
Exit Function
End If
If IsEmpty(rng.Offset(, 1).Value) Then
' 수식이 적용될 시작 셀이 빈 셀임
' 범위를 자동으로 확장할 수 없음
Exit Function
End If
On Error GoTo Err_AutoExpandRange
' 1. 기준셀
Set rngBase = shtView.Range(rng.Offset(, 1).Formula)
' 2. 수식 원본 범위
Set rngFormulaSource = shtView.Range(rng.Formula)
' 3. 기준셀을 시작으로 연속된 범위 계산
Set rngExpand = rngBase.CurrentRegion
' 4. 수식 원본 범위로 열을 제한 - 수식 원본 범위 밖의 컬럼을 모두 제거
Set rngLimit = Application.Intersect(rngExpand, rngFormulaSource.EntireColumn)
' 5. 크기 변경 - 상단으로 확장되었을 수 있으므로 1단계로 행의 크기를 변경
Set rngResize = rngLimit.Resize(rngLimit.Rows.Count - (rngBase.Row - rngLimit.Row))
' 6. 기준셀로 위치 이동 - 상단으로 확장되었을 수 있으므로 기준셀부터 시작하도록 결과를 이동
Set rngMove = rngResize.Offset(rngBase.Row - rngLimit.Row)
Set Get_AutoExpandRange = rngMove
Exit Function
Err_AutoExpandRange:
Set Get_AutoExpandRange = Nothing
End Function
Public Function Get_CRUDExecuteType(CRUD_Execute_Type As CRUDExecuteType) As String
' 'Execute Type : "T" - TRUNCATE / INSERT '
' ' "D" - DELETE / INSERT '
' ' "M" - MERGE INTO '
' ' "N" - INSERT '
' ' "R" - 행 단위로 구분자 지정(U:Update D:Delete C:Insert) '
Select Case CRUD_Execute_Type
Case CRUDExecuteType.MergeInsert
Get_CRUDExecuteType = "M"
Case CRUDExecuteType.DeleteInsert
Get_CRUDExecuteType = "D"
Case CRUDExecuteType.Insert
Get_CRUDExecuteType = "N"
Case CRUDExecuteType.TruncateInsert
Get_CRUDExecuteType = "T"
Case CRUDExecuteType.ByRow
Get_CRUDExecuteType = "R"
Case CRUDExecuteType.UseSheetSetting
Get_CRUDExecuteType = "US"
End Select
End Function
'
' 범위 선택
'
Public Sub Get_Target_Address()
Dim rngAdjSel As Range
Dim rngSingleCell As Range
Dim rngCol As Range
Dim rngRow As Range
Dim rngC As Range
Dim rngR As Range
Dim rngRslt As Range
Dim rng As Range
Dim strR1 As String
Dim strR2 As String
Dim strR3 As String
Dim strR4 As String
Set rngAdjSel = Get_Adj_Cell(rngSingleCell)
If rngAdjSel Is Nothing Then
Exit Sub
End If
Set rngCol = rngAdjSel.Resize(1)
Set rngRow = rngAdjSel.Resize(, 1)
Set rngC = Get_SpecialCells(rngCol, xlCellTypeConstants + xlCellTypeFormulas, xlErrors + xlLogical + xlNumbers + xlTextValues)
Set rngR = Get_SpecialCells(rngRow, xlCellTypeConstants + xlCellTypeFormulas, xlErrors + xlLogical + xlNumbers + xlTextValues)
If rngC Is Nothing Or rngR Is Nothing Then
Call ShowMessage(strPrompt:="대상이 없습니다.", Button:=vbInformation, strTitle:="범위 주소 반환")
'MsgBox "대상이 없습니다.", vbInformation, "범위 주소 반환"
Else
Set rngRslt = Application.Intersect(rngC.EntireColumn, rngR.EntireRow)
If rngRslt Is Nothing Then
Else
strR1 = "="
strR2 = "="
strR3 = "="
strR4 = "="
For Each rng In rngRslt.Areas
With rng
strR1 = strR1 & .Address & ","
strR2 = strR2 & .Address(RowAbsolute:=False) & ","
strR3 = strR3 & .Address(ColumnAbsolute:=False) & ","
strR4 = strR4 & .Address(RowAbsolute:=False, ColumnAbsolute:=False) & ","
End With
Next rng
strR1 = Left(strR1, Len(strR1) - 1)
strR2 = Left(strR2, Len(strR2) - 1)
strR3 = Left(strR3, Len(strR3) - 1)
strR4 = Left(strR4, Len(strR4) - 1)
' debug.Print
' debug.Print
' debug.Print
' debug.Print
' debug.Print "행/열 절대 : " & strR1
' debug.Print
' debug.Print
' debug.Print "행 상대/열 절대 : " & strR2
' debug.Print
' debug.Print
' debug.Print "행 절대/열 상대 : " & strR3
' debug.Print
' debug.Print
' debug.Print "행/열 상대 : " & strR4
If rngSingleCell Is Nothing Then
Exit Sub
End If
rngSingleCell.Formula = strR1
End If
End If
End Sub
Public Function Get_Adj_Cell(rngSingleCell As Range) As Range
Dim rng As Range
Dim rngSingle As Range
For Each rng In Selection.Areas
If rng.Cells.Count = 1 Then
Set rngSingle = Union_Range(rngSingle, rng)
Else
Set Get_Adj_Cell = rng
End If
Next rng
Set rngSingleCell = rngSingle
End Function
모듈명 :
Option Explicit
Option Compare Text
'
' 열 숨기기 처리
' 템플릿에서 공통으로 지정된 범위
'
Public Sub Hide_Columns(sht As Worksheet)
Dim rngHide As Range
Dim rngTarget As Range
Dim rng As Range
Dim rngHideUser As Range
sht.Calculate
' 숨기기 처리할 대상 열 범위 - 예약 범위
Set rngHide = Get_NamedRange("_HIDE_FLAG_COLUMN_", sht)
Call Hide_Column(rngHide)
' 숨기기 처리할 대상 열 범위 - 사용자 지정 범위
Set rngHide = Nothing
Set rngHide = Get_NamedRange("_Def_Hide_Column_", sht)
If rngHide Is Nothing Then
Else
For Each rng In rngHide
If IsEmpty(rng.Value) Then
Else
Set rngHideUser = Get_Range(rng, sht)
Call Hide_Column(rngHideUser)
End If
Next rng
End If
End Sub
'
' 행 숨기기 처리
' 템플릿에서 공통으로 지정된 범위
'
Public Sub Hide_Rows(sht As Worksheet)
Dim rngHide As Range
Dim rngTarget As Range
Dim rng As Range
Dim rngHideUser As Range
sht.Calculate
' 숨기기 처리할 대상 열 범위
Set rngHide = Get_NamedRange("_HIDE_FLAG_ROW_", sht)
Call Hide_Row(rngHide)
' 숨기기 처리할 대상 열 범위 - 사용자 지정 범위
Set rngHide = Nothing
Set rngHide = Get_NamedRange("_Def_Hide_Row_", sht)
If rngHide Is Nothing Then
Else
For Each rng In rngHide
If IsEmpty(rng.Value) Then
Else
Set rngHideUser = Get_Range(rng, sht)
Call Hide_Row(rngHideUser)
End If
Next rng
End If
End Sub
'
' 열 숨기기 처리
' 사용자 지정 범위
'
Public Sub Hide_Column(rng As Range, _
Optional Cell_Type As XlCellType = xlCellTypeFormulas + xlCellTypeConstants, _
Optional Cell_Value As XlSpecialCellsValue = xlErrors)
Dim rngTarget As Range
If rng Is Nothing Then
Exit Sub
End If
' 숨기기 처리할 대상 추출
Set rngTarget = Get_SpecialCells(rngTarget:=rng, CellType:=Cell_Type, CellValue:=Cell_Value)
' 숨기기 처리전 모두 보이기
rng.EntireColumn.Hidden = False
If rngTarget Is Nothing Then
' 숨기기 처리할 대상 열이 없음
Else
' 열 숨기기 처리
rngTarget.EntireColumn.Hidden = True
End If
End Sub
'
' 행 숨기기 처리
' 사용자 지정 범위
'
Public Sub Hide_Row(rng As Range, _
Optional Cell_Type As XlCellType = xlCellTypeFormulas + xlCellTypeConstants, _
Optional Cell_Value As XlSpecialCellsValue = xlErrors)
Dim rngTarget As Range
If rng Is Nothing Then
Exit Sub
End If
' 대상 범위 계산
rng.Calculate
' 숨기기 처리할 대상 추출
Set rngTarget = Get_SpecialCells(rngTarget:=rng, CellType:=Cell_Type, CellValue:=Cell_Value)
' 숨기기 처리전 모두 보이기
rng.EntireRow.Hidden = False
If rngTarget Is Nothing Then
' 숨기기 처리할 대상 행이 없음
Else
' 행 숨기기 처리
rngTarget.EntireRow.Hidden = True
End If
End Sub
모듈명 : m_InitParam
Option Explicit
'
' Parameter 초기화
'
Public Sub Init_Param()
Dim sht As Worksheet
Dim shtActive As Worksheet
Dim bisView As Boolean
' Make Tool Button
Call Auto_Open
' With Application
' .ScreenUpdating = False
' .EnableEvents = False
' .Calculation = xlCalculationManual
' End With
'
' Set shtActive = ActiveSheet
'
With ActiveWorkbook
.Names("VS_DATA_REFRESHED").RefersToRange.Value = False
' .Names("VS_CBO_PLAN_YYYYMM").RefersToRange.Value = "'" & Format(Date, "YYYYMM")
' .Names("VS_PLAN_VERSION").RefersToRange.Value = "MX_FIRST"
'.Names("VS_PLAN_YYYYMM").RefersToRange.Value = Format(Date, "YYYYMM")
.Worksheets("D_VERSION_INFO").Range("A2").CurrentRegion.Offset(1).ClearContents
End With
'
'' For Each sht In ActiveWorkbook.Worksheets
'' bisView = IsView(sht)
'' If bisView Then
'' Application.Goto Reference:=sht.Range("A10000"), Scroll:=True
'' sht.ScrollArea = "A10000"
'' End If
'' Next sht
'
' shtActive.Activate
'
' With Application
' .ScreenUpdating = True
' .EnableEvents = True
' .Calculation = xlCalculationAutomatic
' End With
End Sub
모듈명 : m_MakeCRUDData
Option Explicit
Public Function Make_CRUD_Data_New(shtCRUD As Worksheet, rngBase As Range, ErrorMessage As String) As Boolean
Dim rng As Range
Dim rngPK As Range
Dim CheckResult As Long
' Base Row
Dim rngKeyBaseColumn As Range
Dim rngKeyBaseRow As Range
Dim rngValueBase As Range
' 기본 대상 전체 영역
Dim rngKeyBaseTargetColumn As Range
Dim rngKeyBaseTargetRow As Range
Dim rngValueBaseTarget As Range
' 실 대상 영역
Dim rngKeyRealTargetColumn As Range
Dim rngKeyRealTargetRow As Range
Dim rngValueRealTarget As Range
' 전체 CRUD 시트 영역의 추출 범위
Dim rngAll As Range
' Key 검사
Dim rngFirstKey As Range
Dim isNamedRangeFlag As Boolean
Dim rngValue As Range
Dim iSize As Long
Dim bSwapFlag As Boolean
Dim rngKeySource As Range
Dim KeyDirection As FirstKey_Direction
On Error GoTo MakeError
' 기본 정보 영역
Set rngKeyBaseColumn = shtCRUD.Range("C7").EntireRow
Set rngKeyBaseRow = shtCRUD.Range("C8").EntireRow
Set rngValueBase = shtCRUD.Range("C9").EntireRow
' 전체 영역 계산
Set rngAll = rngBase.CurrentRegion.EntireColumn.Offset(, 2)
Set rngAll = rngAll.Resize(, rngAll.Columns.Count - 2)
' 기본 대상 영역 추출
Set rngKeyBaseTargetColumn = Application.Intersect(rngKeyBaseColumn, rngAll)
Set rngKeyBaseTargetRow = Application.Intersect(rngKeyBaseRow, rngAll)
Set rngValueBaseTarget = Application.Intersect(rngValueBase, rngAll)
' 실 대상 영역 추출
Set rngKeyRealTargetColumn = Get_SpecialCells(rngKeyBaseTargetColumn, xlCellTypeFormulas, xlErrors + xlLogical + xlNumbers + xlTextValues)
Set rngKeyRealTargetRow = Get_SpecialCells(rngKeyBaseTargetRow, xlCellTypeFormulas, xlErrors + xlLogical + xlNumbers + xlTextValues)
' 값 영역은 수식으로 작성된 부분만 추출하고 상수로 입력된 영역은 맨 마지막에 일괄 처리
Set rngValueRealTarget = Get_SpecialCells(rngValueBaseTarget, xlCellTypeFormulas, xlErrors + xlLogical + xlNumbers + xlTextValues)
' ------------------------------------------------------------
' Key, Data 범위의 유효성 검사 시작
' ------------------------------------------------------------
CheckResult = Check_Key_Value_Range_New(rngFirstKey, _
rngKeyBaseColumn, _
rngKeyBaseRow, _
rngValueBase, _
rngAll, _
rngKeyBaseTargetColumn, _
rngKeyBaseTargetRow, _
rngValueBaseTarget, _
rngKeyRealTargetColumn, _
rngKeyRealTargetRow, _
rngValueRealTarget, _
ErrorMessage, _
iSize, _
KeyDirection)
' 검사 오류 체크
If CheckResult > 0 Then
' 셋팅된 범위에 오류가 있음 - 종료
Make_CRUD_Data_New = False
Exit Function
End If
' ------------------------------------------------------------
' Key, Data 범위의 유효성 검사 끝
' ------------------------------------------------------------
' ============================================================
' 데이터 생성 시작
' ============================================================
' ------------------------------------------------------------
' 1. 데이터 생성 시작 - 수식 처리 부분
' ------------------------------------------------------------
Set rngValue = Set_Values_New(shtCRUD, rngKeyRealTargetColumn, rngKeyRealTargetRow, rngValueRealTarget, rngBase, KeyDirection)
' ------------------------------------------------------------
' 1. 데이터 생성 끝 - 수식 처리 부분
' ------------------------------------------------------------
' ------------------------------------------------------------
' 2. 데이터 생성 시작 - 상수/이름 정의/단일 셀 처리 부분
' ------------------------------------------------------------
' 값 영역 상수 처리
Set rngValueRealTarget = Get_SpecialCells(rngValueBaseTarget, xlCellTypeConstants, xlErrors + xlLogical + xlNumbers + xlTextValues)
' 전체 출력된 건수 계산
Set rng = Get_ResizeBaseRange(rngBase)
iSize = rng.Rows.Count
If rngValueRealTarget Is Nothing Then
' 대상 영역이 없음
Else
For Each rngValue In rngValueRealTarget.Areas
' 값 복사
Call Set_Value(rngBase.Offset(1).EntireRow, rngValue.EntireColumn, iSize, rngValue)
Next rngValue
End If
' 열 키 영역 상수/이름 정의/단일 셀 처리
Call Set_Value_Const(rngBase, rngKeyBaseTargetColumn, iSize)
' 행 키 영역 상수/이름 정의/단일 셀 처리
Call Set_Value_Const(rngBase, rngKeyBaseTargetRow, iSize)
' ------------------------------------------------------------
' 2. 데이터 생성 끝 - 상수/이름 정의/단일 셀 처리 부분
' ------------------------------------------------------------
' ------------------------------------------------------------
' 3. 데이터 생성 시작 - Key 값에 값이 없는 데이터 행 삭제 처리
' ------------------------------------------------------------
Call Clear_NA_Row(shtCRUD, rngAll, rngBase)
' ------------------------------------------------------------
' 3. 데이터 생성 끝 - Key 값에 값이 없는 데이터 행 삭제 처리
' ------------------------------------------------------------
' ============================================================
' 데이터 생성 끝
' ============================================================
Make_CRUD_Data_New = True
ErrorMessage = ""
Exit Function
MakeError:
ErrorMessage = "확인되지 않은 오류입니다." & vbCr & vbCr & _
"오류 코드 : " & Err.Number & vbCr & vbCr & _
"오류 내용 : " & Err.Description
Make_CRUD_Data_New = False
Stop
' 디버그를 위한 ' Stop 이므로 저에게 알려주세요...
Resume
End Function
Public Function Set_Values_New(shtCRUD As Worksheet, _
rngKeyRealTargetColumn As Range, _
rngKeyRealTargetRow As Range, _
rngValueRealTarget As Range, _
rngBase As Range, _
KeyDirection As FirstKey_Direction) As Range
Dim rng As Range
Dim rngFirstKeyNew As Range
Dim rngColKey As Range
Dim rngRowKey As Range
Dim rngCKey As Range
Dim rngRKey As Range
Dim rngData As Range
Dim rngKey As Range
Dim strKey As String
Dim rngKeyResult As Range
Dim rngKeyNamed As Range
Dim rngValue As Range
Dim rngDatas As Range
Dim rngDataFirst As Range
Dim rngTarget As Range
Dim rngDestination As Range
Dim rngNamed As Range
Dim rngCKeyLoop As Range
Dim rngColKeyData As Range
Dim rngColKeyValue As Range
Dim strColKeyRealTarget As String
Dim strColKeyList As String
Dim strValue As String
Dim DataCount As Long
Dim isNamed As Boolean
Dim arrKeyList As Variant
Dim arrValues As Variant
Dim i As Integer
Dim isKeyError As Boolean
On Error GoTo Err_Exit
' If IsError(rngColumnKey.Value) Then
' ' 오류 키는 처리 안함
' Set Get_Values_New = Nothing
' Exit Function
' End If
'
' If IsEmpty(rngColumnKey.Value) Then
' ' 빈 셀은 처리 안함
' Set Get_Values_New = Nothing
' Exit Function
' End If
' 열 키 만들기
For Each rng In rngKeyRealTargetColumn
isNamed = isNamedRange(rng.Formula)
If isNamed Then
If InStr(rng.Formula, "!") > 0 Then
Set rngKey = Range(rng.Formula)
Else
Set rngKey = Nothing
End If
Else
Set rngKey = Range(rng.Formula)
End If
Set rngColKey = Union_Range(rngColKey, rngKey)
Next rng
' ' 행 키 만들기
' Set rngKey = Nothing
' For Each rng In rngKeyRealTargetRow
'
' isNamed = isNamedRange(rng.Formula)
' If isNamed Then
' Else
' Set rngKey = Range(rng.Formula)
' End If
'
' Set rngRowKey = Union_Range(rngRowKey, rngKey)
'
' Next rng
For Each rng In rngValueRealTarget
isNamed = isNamedRange(rng.Formula)
If isNamed Then
'' debug.Print "Value Real Target : ", rng.Formula
If InStr(rng.Formula, "!") > 0 Then
Set rngDatas = Range(rng.Formula)
Else
Set rngDatas = Nothing
End If
' Set rngDatas = Range(rng.Formula)
' ' Stop
''''' ' Stop
' 디버그를 위한 ' Stop 이므로 저에게 알려주세요...
Else
'Set rngDatas = Range(rng.Formula)
Set rngDatas = Get_Range(rng)
End If
If KeyDirection = FirstKey_Direction.Column Then
Set rngDataFirst = Application.Intersect(rngDatas, rngDatas.Range("A1").EntireRow)
Else
Set rngDataFirst = Application.Intersect(rngDatas, rngDatas.Range("A1").EntireColumn)
End If
If KeyDirection = FirstKey_Direction.Column Then
DataCount = rngDatas.Rows.Count
Else
DataCount = rngDatas.Columns.Count
End If
For Each rngData In rngDataFirst
If KeyDirection = FirstKey_Direction.Column Then
Set rngCKey = Application.Intersect(rngColKey, rngData.EntireColumn)
Else
Set rngCKey = Application.Intersect(rngColKey, rngData.EntireRow)
End If
strColKeyList = ""
isKeyError = False
' 컬럼 Key 값 위치 계산
For Each rngCKeyLoop In rngKeyRealTargetColumn
isNamed = isNamedRange(rngCKeyLoop.Formula)
If isNamed Then
' ' Stop
If InStr(rngCKeyLoop.Formula, "!") > 0 Then
Set rngColKeyData = Range(rngCKeyLoop.Formula)
Else
Set rngColKeyData = Nothing
End If
Else
Set rngColKeyData = Range(rngCKeyLoop.Formula)
End If
If rngColKeyData Is Nothing Then
Else
' Set rngColKeyData = Range(rngCKeyLoop.Formula)
If KeyDirection = FirstKey_Direction.Column Then
Set rngColKeyValue = Application.Intersect(rngColKeyData, rngColKey, rngData.EntireColumn)
Else
Set rngColKeyValue = Application.Intersect(rngColKeyData, rngColKey, rngData.EntireRow)
End If
' 지정되지않은 키 범위 검사
If rngColKeyValue Is Nothing Then
isKeyError = True
Exit For
End If
' 데이터 오류 및 빈 셀 검사
If IsError(rngColKeyValue.Value) Then
isKeyError = True
Exit For
ElseIf IsEmpty(rngColKeyValue.Value) Then
isKeyError = True
Exit For
Else
strColKeyList = strColKeyList & rngCKeyLoop.Address & "<|>" & rngColKeyValue.Value & "<||>"
End If
End If
Next rngCKeyLoop
If isKeyError Then
' 지정되지 않은 Key, Key 오류 또는 빈 Key 이므로 처리 안함
Else
strColKeyList = Left(strColKeyList, Len(strColKeyList) - 4)
' 값 복사 대상 위치 계산
Set rngTarget = Get_Target(shtCRUD, strColKeyList, rngKeyRealTargetColumn, rngBase)
Set rngDestination = shtCRUD.Cells(rngTarget.Row, rng.Column).Resize(DataCount)
' 데이터 복사
If KeyDirection = FirstKey_Direction.Column Then
Set rngValue = rngData.Resize(DataCount)
rngValue.Copy
rngDestination.PasteSpecial Paste:=xlPasteValues
Else
Set rngValue = rngData.Resize(, DataCount)
rngValue.Copy
rngDestination.PasteSpecial Paste:=xlPasteValues, Transpose:=True
End If
' 열 Key 복사
arrKeyList = Split(strColKeyList, "<||>")
For i = 0 To UBound(arrKeyList)
arrValues = Split(arrKeyList(i), "<|>")
Set rngKey = Worksheets(rngKeyRealTargetColumn.Parent.Name).Range(CStr(arrValues(0)))
strValue = CStr(arrValues(1))
Set rngTarget = Application.Intersect(rngKey.EntireColumn, rngDestination.EntireRow)
rngTarget.Value = strValue
Next i
End If
Next rngData
Next rng
'' Stop
' 행 Key 셋팅
' 전체 결과 영역 계산
Set rngDatas = Get_ResizeBaseRange(rngBase)
For Each rngRowKey In rngKeyRealTargetRow
isNamed = isNamedRange(rngRowKey.Formula)
If isNamed Then
Set rngKey = Range(rngRowKey.Formula)
''''' ' Stop
' Key 복사 대상 범위 계산/복사
Set rngDestination = Application.Intersect(rngDatas.EntireRow, rngRowKey.EntireColumn)
rngKey.Copy
If KeyDirection = FirstKey_Direction.Column Then
rngDestination.PasteSpecial Paste:=xlPasteValues
Else
rngDestination.PasteSpecial Paste:=xlPasteValues, Transpose:=True
End If
Else
Set rngKey = Range(rngRowKey.Formula)
' Key 복사 대상 범위 계산/복사
Set rngDestination = Application.Intersect(rngDatas.EntireRow, rngRowKey.EntireColumn)
rngKey.Copy
If KeyDirection = FirstKey_Direction.Column Then
rngDestination.PasteSpecial Paste:=xlPasteValues
Else
rngDestination.PasteSpecial Paste:=xlPasteValues, Transpose:=True
End If
End If
Next rngRowKey
Err_Exit:
End Function
Public Function Get_Target(shtCRUD As Worksheet, strColKeyList As String, rngKeyRealTargetColumn As Range, rngBase As Range) As Range
Dim rngAll As Range
Dim rngData As Range
Dim rng As Range
Dim arrKeyList As Variant
Dim arrValues As Variant
Dim i As Integer
Dim rngKey As Range
Dim rngWhere As Range
Dim rngFind As Range
Dim strValue As String
Dim isDate As Boolean
On Error GoTo Find_Err
' 전체 영역 계산
Set rngAll = rngBase.CurrentRegion
Set rng = rngAll.Offset(rngBase.Row - rngAll.Row + 1, 2).Resize(, rngAll.Columns.Count - 2)
Set rngData = Application.Intersect(rngAll, rng)
If rngData Is Nothing Then
Set Get_Target = rngBase.Offset(1)
Exit Function
End If
arrKeyList = Split(strColKeyList, "<||>")
For i = 0 To UBound(arrKeyList)
arrValues = Split(arrKeyList(i), "<|>")
Set rngKey = shtCRUD.Range(CStr(arrValues(0)))
strValue = CStr(arrValues(1))
If rngWhere Is Nothing Then
Set rngWhere = Application.Intersect(rngKey.EntireColumn, rngData)
Else
Set rngWhere = Application.Intersect(rngKey.EntireColumn, rngData, rngWhere.EntireRow)
End If
' ' Stop
isDate = Is_DateFormat(strValue)
If isDate Then
Set rngFind = rngWhere.Find(What:=DateValue(strValue), LookIn:=xlValues, LookAt:=xlWhole, After:=rngWhere.Offset(rngWhere.Rows.Count - 1).Range("A1"))
Else
Set rngFind = rngWhere.Find(What:=strValue, LookIn:=xlValues, LookAt:=xlWhole, After:=rngWhere.Offset(rngWhere.Rows.Count - 1).Range("A1"))
End If
If rngFind Is Nothing Then
' Key 찾지 못함
Set Get_Target = rngBase.Offset(rngData.Rows.Count + 1)
Exit Function
End If
Set rngWhere = rngWhere.Offset(rngFind.Row - rngWhere.Row)
Next i
Set Get_Target = rngBase.Offset(rngWhere.Row - rngBase.Row)
Find_Err:
' ' Stop
End Function
Public Function Is_DateFormat(strValue As String) As Boolean
Dim isDate As Boolean
Dim Date_Value As Date
On Error GoTo isDateErr
Date_Value = DateValue(strValue)
Is_DateFormat = True
Exit Function
isDateErr:
Is_DateFormat = False
Err.Clear
End Function
모듈명 : m_PageLayout
Option Explicit
'
' 페이지 레이아웃 메뉴 생성
'
Public Sub Make_PageLayout()
Dim cbar As CommandBar
Dim cPopup As CommandBarPopup
Dim cCell As CommandBar
' Set cbar = Application.CommandBars("column")
Set cCell = Application.CommandBars("Cell")
cCell.Reset
On Error Resume Next
For Each cbar In Application.CommandBars
Set cPopup = cCell.Controls.Add(Type:=msoControlPopup, Temporary:=True)
cPopup.Caption = cbar.Name ' b"페이지 보기"
Call Make_PageLayout_Button(cPopup, "기본", "View_Default")
Call Make_PageLayout_Button(cPopup, "페이지 레이아웃", "View_PageLayout")
Call Make_PageLayout_Button(cPopup, "페이지 나누기 미리 보기", "View_PageBreak")
Next cbar
End Sub
Public Sub Make_PageLayout_Button(cPopup As CommandBarPopup, strCaption As String, strAction As String)
Dim cBtn As CommandBarButton
Set cBtn = cPopup.Controls.Add(Type:=msoControlButton)
With cBtn
.Caption = strCaption
.OnAction = strAction
End With
End Sub
Public Sub View_Default()
ActiveWindow.View = xlNormalView
End Sub
Public Sub View_PageLayout()
ActiveWindow.View = xlPageLayoutView
End Sub
Public Sub View_PageBreak()
ActiveWindow.View = xlPageBreakPreview
End Sub
Public Sub dafsafafgaf()
Dim cbar As CommandBar
Dim cctl As CommandBarControl
Dim i As Integer
i = 2
For Each cbar In CommandBars
For Each cctl In cbar.Controls
Cells(i, 1).Value = cbar.Name
Cells(i, 2).Value = cctl.Caption
i = i + 1
Next cctl
Next
End Sub
모듈명 : m_PasteText
Option Explicit
'
' 텍스트 붙여넣기 메뉴 생성
'
Public Sub Make_PasteText()
Dim cbar As CommandBar
Dim cBtn As CommandBarButton
Set cbar = Application.CommandBars("Cell")
Set cBtn = cbar.Controls.Add(Type:=msoControlButton, Temporary:=True)
With cBtn
.Caption = "텍스트 붙여넣기"
.OnAction = "PasteTextOnly"
End With
End Sub
Public Sub Make_PageLayout_Button(cPopup As CommandBarPopup, strCaption As String, strAction As String)
Dim cBtn As CommandBarButton
Set cBtn = cPopup.Controls.Add(Type:=msoControlButton)
With cBtn
.Caption = strCaption
.OnAction = strAction
End With
End Sub
Public Sub PasteTextOnly()
On Error GoTo Err_PasteText
ActiveSheet.PasteSpecial Format:="텍스트", Link:=False, DisplayAsIcon:=False
Exit Sub
Err_PasteText:
Err.Clear
Call ShowMessage(strPrompt:="텍스트를 붙여넣을 수 없습니다.", Button:=vbInformation, strTitle:="붙여넣기 오류")
'MsgBox "텍스트를 붙여넣을 수 없습니다.", vbExclamation, "붙여넣기 오류"
End Sub
모듈명 : m_Repare
Public Sub Repare_Book()
'
' 단축키 CONTROL + SHIFT + R
'
Dim wbOld As Workbook
Dim wbNew As Workbook
Dim shtNew As Worksheet
Dim i As Integer
Set wbOld = ActiveWorkbook
Set wbNew = Workbooks("Template_Case1.xls") '.Add
For i = 1 To wbOld.Worksheets.Count
'If i > wbNew.Worksheets.Count Then
Set shtNew = wbNew.Worksheets.Add(After:=wbNew.Worksheets(wbNew.Worksheets.Count - 1))
'Else
' Set shtNew = wbNew.Worksheets(i)
'End If
shtNew.Name = wbOld.Worksheets(i).Name
wbOld.Worksheets(i).Cells.Copy
shtNew.Range("a1").PasteSpecial Paste:=xlPasteAll
shtNew.Tab.Color = wbOld.Worksheets(i).Tab.Color
Next i
End Sub
모듈명 : m_Save
Option Explicit
'
' 권한 체크
'
Public Function Check_Auth(strMsg As String) As Boolean
Dim bAuth As Boolean
' 저장 권한 체크
bAuth = Get_Auth(User_Auth.Auth_Save)
If bAuth = False Then
strMsg = "저장 권한이 없습니다."
Call ShowMessage(strPrompt:=strMsg, Button:=vbInformation, strTitle:="권한 없음")
'MsgBox strMsg, vbInformation, "권한 없음"
Check_Auth = False
Exit Function
End If
' 승인요청 권한 체크
bAuth = Get_Auth(User_Auth.Auth_ReqApproval)
If bAuth = False Then
strMsg = "승인 요청 권한이 없습니다."
Call ShowMessage(strPrompt:=strMsg, Button:=vbInformation, strTitle:="권한 없음")
' MsgBox strMsg, vbInformation, "권한 없음"
Check_Auth = False
Exit Function
End If
' 승인 권한 체크
bAuth = Get_Auth(User_Auth.Auth_Approval)
If bAuth = False Then
strMsg = "승인 권한이 없습니다."
Call ShowMessage(strPrompt:=strMsg, Button:=vbInformation, strTitle:="권한 없음")
'MsgBox strMsg, vbInformation, "권한 없음"
Check_Auth = False
Exit Function
End If
Check_Auth = True
End Function
'
' C_BasePoint 이름 정의 복구
'
Public Sub Repare_C_BasePoint(sht As Worksheet)
Dim nmBasePoint As Name
On Error Resume Next
' 이름 정의 검사
Set nmBasePoint = sht.Names("C_Caption")
If Err.Number = 0 Then
' CURD 시트인지 확인하고 오류가 없으면 이름 정의 수정(생성)
Set nmBasePoint = sht.Names.Add(Name:="C_BasePoint", RefersToR1C1:=sht.Range("D20"))
End If
End Sub
Public Function Get_Auth(UserAuth As User_Auth) As Boolean
Dim nmAuth As Name
' 개발 모드로 무조건 권한 있음 리턴
Get_Auth = True
Exit Function
' 권한 없음으로 기본값 설정
Get_Auth = False
Select Case UserAuth
Case User_Auth.Auth_Save
Set nmAuth = ActiveWorkbook.Names("VS_AUTH_SAVE").RefersToRange
Get_Auth = nmAuth.Value = "1"
Case User_Auth.Auth_ReqApproval
Set nmAuth = ActiveWorkbook.Names("VS_AUTH_REQ_APPROVAL").RefersToRange
Get_Auth = nmAuth.Value = "1"
Case User_Auth.Auth_Approval
Set nmAuth = ActiveWorkbook.Names("VS_AUTH_APPROVAL").RefersToRange
Get_Auth = nmAuth.Value = "1"
Case Else
' 알 수 없는 권한 요청
' 기본값(권한 없음) 리턴
End Select
End Function
''--------------------------------------------------------------------------------'
' 'Conn.crud Target Sheet, Execute Type, [Data Range] '
' 'Sheet : CRUD Sheet (표준양식 반드시 준수) '
' 'Execute Type : "T" - TRUNCATE / INSERT '
' ' "D" - DELETE / INSERT '
' ' "M" - MERGE INTO '
' ' "N" - INSERT '
' ' "R" - 행 단위로 구분자 지정(U:Update D:Delete C:Insert) '
' '[Data Range]: Execute Range / 미지정 시 전체 데이터 실행 '
' 'Me = 해당 시트 (모듈에서 사용할 경우 시트를 명확히 재지정) '
''--------------------------------------------------------------------------------'
Public Function MTX_MultiCRUD(SheetNameList As String, _
strMsg As String, _
Optional CRUD_Execute_Type As CRUDExecuteType = CRUDExecuteType.MergeInsert, _
Optional CopyFormula As Boolean = False) As Boolean
Dim bSuccess As Boolean
Dim bKeySuccess As Boolean
Dim bNeedMakeData As Boolean
Dim WorkResultMessage As String
Dim strSheetList As String
Dim arrSheetList As Variant
Dim i As Integer
Dim sht As Worksheet
Dim rng As Range
Dim rngData As Range
Dim rngClear As Range
Dim rData As Range
Dim strNewSheetList As String
Dim strExecute As String
Dim bVer_Status As Boolean
Dim bAuth As Boolean
Dim resp As VbMsgBoxResult
Dim bIsSim As Boolean
Dim bCheckVersion As Boolean
Dim s, e, s1, e1 As Variant
'
' 저장전 점검
'
' bCheckVersion = Check_Before_Save(strMsg)
'
' If bCheckVersion Then
' Else
' MTX_MultiCRUD = False
' Exit Function
' End If
' Simulation 버전 여부 확인
bIsSim = IsSimulationVersion()
' ' 권한 체크
' bAuth = Check_Auth(strMsg)
'
' If bAuth Then
' Else
' MTX_MultiCRUD = False
' Exit Function
' End If
'
' '
' ' 버전 마감 여부 확인
' '
'
' bVer_Status = Get_Version_Status
'
' If bVer_Status = False Then
' strMsg = "마감된 버전은 저장할 수 없습니다."
'
' Call ShowMessage(strPrompt:=strMsg, Button:=vbInformation, strTitle:="저장")
' 'MsgBox strMsg, vbInformation, "저장"
'
' MTX_MultiCRUD = False
' Exit Function
' End If
' Simulation Version 여부 확인
If bIsSim Then
Else
resp = ShowMessage(strPrompt:="저장하시겠습니까?", Button:=vbYesNo + vbQuestion, strTitle:="저장")
'resp = MsgBox("저장하시겠습니까?", vbYesNo + vbQuestion, "저장")
If resp = vbNo Then
strMsg = "취소되었습니다."
Call ShowMessage(strPrompt:=strMsg, Button:=vbInformation, strTitle:="저장")
'MsgBox strMsg, vbInformation, "저장"
MTX_MultiCRUD = False
Exit Function
End If
End If
If SheetNameList = "" Then
' 대상 시트가 지정되지 않았음
' 모든 시트를 대상으로 작업
For Each sht In ActiveWorkbook.Worksheets
Set rng = Get_NamedRange("C_Caption", sht)
If rng Is Nothing Then
Else
strSheetList = strSheetList & sht.Name & ","
End If
Next sht
Else
' 시트가 지정됨
' 해당 시트에서만 작업
strSheetList = SheetNameList
End If
If Right(strSheetList, 1) = "," Then
strSheetList = Left(strSheetList, Len(strSheetList) - 1)
End If
' 연속된 ,, 문자 모두 제거
Do
If InStr(strSheetList, ",,") > 0 Then
strSheetList = Application.WorksheetFunction.Substitute(strSheetList, ",,", ",")
Else
Exit Do
End If
Loop
' 대상 시트명 분리
arrSheetList = Split(strSheetList, ",")
' 대상 시트가 존재하는지 검사
bSuccess = Check_Exists_Sheet(arrSheetList, WorkResultMessage)
If bSuccess Then
Else
' 데이터 생성 실패
MTX_MultiCRUD = False
strMsg = WorkResultMessage
Call ShowMessage(strPrompt:=strMsg, Button:=vbInformation, strTitle:="저장 오류")
'MsgBox WorkResultMessage, vbCritical + vbOKOnly, "저장 오류"
Exit Function
End If
' 대상 시트에 지정된 Key가 유효한지 검사
bKeySuccess = Check_Key_Data(arrSheetList, strNewSheetList, bNeedMakeData, WorkResultMessage)
If bKeySuccess Then
' 기본 검사 성공
' 자동 생성 여부 검사
If bNeedMakeData Then
' 자동 생성이 필요함
' 대상 시트명 분리
' 자동 생성이 필요없는 시트명이 정리된 새로 정리한 시트명으로 자동생성 목록 생성
arrSheetList = Split(strNewSheetList, ",")
Else
'
' 자동 생성 필요 없음
' 저장 실행
'
bSuccess = Exec_CRUD(strSheetList, strMsg, CRUD_Execute_Type)
MTX_MultiCRUD = bSuccess
Exit Function
End If
Else
' 오류 - 종료
MTX_MultiCRUD = False
strMsg = WorkResultMessage
Call ShowMessage(strPrompt:=strMsg, Button:=vbInformation, strTitle:="저장 오류")
'MsgBox WorkResultMessage, vbCritical + vbOKOnly, "저장 오류"
strMsg = WorkResultMessage
Exit Function
End If
' 시트별 저장할 데이터 생성
For i = 0 To UBound(arrSheetList)
' 작업 대상 워크시트 확인
Set sht = Get_WorkSheet(CStr(arrSheetList(i)))
' 기존 데이터 Clear
Set rData = sht.Range("C_Caption")
Set rngData = Get_ResizeBaseRange(rData)
If rngData Is Nothing Then
Else
Set rngClear = Application.Intersect(rData.CurrentRegion, rngData.EntireRow)
If rngClear Is Nothing Then
Else
rngClear.ClearContents
End If
End If
s1 = Timer
' ----------------------------------------------------------------------------
If InStr(CStr(arrSheetList(i)), "[|][FORMULA]") > 0 Then
' 수식에 의한 데이터 생성 호출
bSuccess = Make_Data4Save_Formula(sht, WorkResultMessage)
e1 = Timer
Debug.Print sht.Name, "데이터생성_수식", s1, e1, e1 - s1
Else
' 자동 생성을 위한 데이터 생성 호출
bSuccess = Make_Data4Save(sht, WorkResultMessage)
e1 = Timer
Debug.Print sht.Name, "데이터생성_자동", s1, e1, e1 - s1
End If
' 이름 정의 복구
Call Repare_C_BasePoint(sht)
If bSuccess Then
' 데이터 생성 성공
' 데이터 조건 무결성 검증
'Set rPoint = rData.Offset(1)
'Set rPoint = sht.Range("C_BasePoint")
Set rngData = Get_ResizeBaseRange(rData)
strExecute = sht.Range("c_Execute").Value
If rngData Is Nothing Then
strMsg = "오류 : 생성된 데이터가 없습니다." & vbCr & vbCr & _
"대상 시트명 : " & arrSheetList(i)
Call ShowMessage(strPrompt:=strMsg, Button:=vbCritical + vbOKOnly, strTitle:="저장 오류")
MTX_MultiCRUD = False
Exit Function
Else
If strExecute = "R" And Application.WorksheetFunction.CountA(rngData.Offset(, -1)) = 0 Then
strMsg = "오류 : C열에 구분자를 입력(U:Update, D:Delete, C:Insert) 하십시요." & vbCr & vbCr & _
"대상 시트명 : " & arrSheetList(i)
Call ShowMessage(strPrompt:=strMsg, Button:=vbCritical + vbOKOnly, strTitle:="저장 오류")
'MsgBox strMsg, vbCritical + vbOKOnly, "저장 오류"
MTX_MultiCRUD = False
Exit Function
End If
End If
Else
' 데이터 생성 실패
MTX_MultiCRUD = False
strMsg = "오류 : " & WorkResultMessage & vbCr & vbCr & _
"대상 시트명 : " & arrSheetList(i)
Call ShowMessage(strPrompt:=strMsg, Button:=vbCritical + vbOKOnly, strTitle:="저장 오류")
'MsgBox strMsg, vbCritical + vbOKOnly, "저장 오류"
Exit Function
End If
' ----------------------------------------------------------------------------
Next i
e = Timer
Debug.Print "데이터 생성 완료", s, e, e - s
s = Timer
bSuccess = Exec_CRUD(strSheetList, strMsg, CRUD_Execute_Type)
MTX_MultiCRUD = bSuccess
e = Timer
Debug.Print "데이터 저장 완료", s, e, e - s
Exit Function
hErr:
If Err <> 0 Then
strMsg = Err.Description
Call ShowMessage(strPrompt:=strMsg, Button:=vbCritical + vbOKOnly, strTitle:="저장 오류")
'MsgBox Err.Description
End If
MTX_MultiCRUD = (Err = 0)
End Function
Public Function Exec_CRUD_backup20170822(strSheetList As String, strMsg As String, CRUD_Execute_Type As CRUDExecuteType) As Boolean
Dim lngEnd As Long
'Dim rPoint As Range
Dim rData As Range
Dim strExecute As String
Dim strShtList As String
Dim addin As COMAddIn
Dim mxmodule As Object
Dim strCRUDExecType As String
Dim strSht As String
Dim arrSht As Variant
Dim i As Integer
Dim strMsgCRUD As String
On Error GoTo Exec_CRUD_Err
strShtList = Application.WorksheetFunction.Substitute(strSheetList, ",", ";")
Set addin = Application.COMAddIns.Item("ExcelModule.AddinModule")
Set mxmodule = addin.Object
arrSht = Split(strShtList, ";")
Exec_CRUD_backup20170822 = True
strCRUDExecType = Get_CRUDExecuteType(CRUD_Execute_Type)
For i = 0 To UBound(arrSht)
strSht = arrSht(i)
' merge
If strCRUDExecType = "US" Then
Else
ActiveWorkbook.Worksheets(strSht).Names("c_Execute").RefersToRange.Value = strCRUDExecType
End If
mxmodule.xapi.MultiCRUD ActiveWorkbook, strSht
If mxmodule.xapi.LastErrorCode <> 0 Then
If mxmodule.xapi.LastErrorMessage = "Unknown error" Then
strMsg = "DB접속 정보가 없습니다."
' MsgBox strMsg, vbCritical, cstrMsgTitleSave
Exec_CRUD_backup20170822 = False
strMsgCRUD = strMsgCRUD & strMsg & vbCr & vbCr
Else
strMsgCRUD = strMsgCRUD & mxmodule.xapi.LastErrorMessage & vbCr & vbCr
' MsgBox mxmodule.xapi.LastErrorMessage, vbCritical, cstrMsgTitleSave
Exec_CRUD_backup20170822 = False
End If
Else
strMsgCRUD = strMsgCRUD & "Info" & mxmodule.xapi.ResponseData & vbCr & vbCr
End If
Next i
strMsg = strMsgCRUD
Call ShowMessage(strPrompt:=strMsg, Button:=vbInformation, strTitle:="저장")
'MsgBox strMsgCRUD, vbInformation, cstrMsgTitleSave '''저장 되었으면
' mxmodule.xapi.LastErrorMessage
' Else
' strMsg = "저장 되었습니다." & vbCrLf & "Info" & mxmodule.xapi.ResponseData
' MsgBox strMsg, vbInformation, cstrMsgTitleSave '''저장 되었으면
'Exec_CRUD = True
Set addin = Nothing
Set mxmodule = Nothing
Exit Function
Exec_CRUD_Err:
Exec_CRUD_backup20170822 = (Err.Number = 0)
Set addin = Nothing
Set mxmodule = Nothing
End Function
'
' 다중시트 CRUD 오류 발생(파일찾지 못하는 오류) -> 서버 패치 -> 다중시트에서 전체 트랜잭션 관리가 되도록 수정
' 수정일 2017-08-22
' 이기춘
'
Public Function Exec_CRUD(strSheetList As String, strMsg As String, CRUD_Execute_Type As CRUDExecuteType) As Boolean
Dim arrSht As Variant
Dim i As Integer
Dim strSht As String
Dim lngEnd As Long
'Dim rPoint As Range
Dim rData As Range
Dim strExecute As String
Dim strShtList As String
Dim addin As COMAddIn
Dim mxmodule As Object
Dim strCRUDExecType As String
Dim bUnitConvert As Boolean
Dim bIsSim As Boolean
' Simulation Version 여부 확인
bIsSim = IsSimulationVersion
On Error GoTo Exec_CRUD_Err
strShtList = Application.WorksheetFunction.Substitute(strSheetList, ",", ";")
Set addin = Application.COMAddIns.Item("ExcelModule.AddinModule")
Set mxmodule = addin.Object
arrSht = Split(strShtList, ";")
strCRUDExecType = Get_CRUDExecuteType(CRUD_Execute_Type)
bUnitConvert = True
For i = 0 To UBound(arrSht)
strSht = arrSht(i)
If strCRUDExecType = "US" Then
' 사용자 지정이면 타입은 그대로 유지
Else
ActiveWorkbook.Worksheets(strSht).Names("c_Execute").RefersToRange.Value = strCRUDExecType
End If
'
' 숫자 단위 셋팅
'
' 2017-08-31
'
bUnitConvert = Set_Numeric_Unit(strSht, strMsg)
' 단위 변환 오류 검사
'
' 2017-08-31
'
If bUnitConvert Then
' 성공
Else
' 단위 변환 실패
Exec_CRUD = False
Exit Function
End If
Next i
' CRUD 실행
mxmodule.xapi.MultiCRUD ActiveWorkbook, strShtList
If mxmodule.xapi.LastErrorCode <> 0 Then
If mxmodule.xapi.LastErrorMessage = "Unknown error" Then
strMsg = "DB접속 정보가 없습니다."
Else
strMsg = mxmodule.xapi.LastErrorMessage
End If
Call ShowMessage(strPrompt:=strMsg, Button:=vbCritical, strTitle:=cstrMsgTitleSave)
'MsgBox strMsg, vbCritical, cstrMsgTitleSave
Exec_CRUD = False
Else
strMsg = "저장 되었습니다." & vbCrLf & "Info" & mxmodule.xapi.ResponseData
Call ShowMessage(strPrompt:=strMsg, Button:=vbInformation, strTitle:=cstrMsgTitleSave)
'MsgBox strMsg, vbInformation, cstrMsgTitleSave '''저장 되었으면
Exec_CRUD = True
End If
Set addin = Nothing
Set mxmodule = Nothing
Exit Function
Exec_CRUD_Err:
Exec_CRUD = (Err.Number = 0)
Set addin = Nothing
Set mxmodule = Nothing
End Function
Public Function Make_Data4Save(TargetSheet As Worksheet, WorkResultMessage As String) As Boolean
' ======================================================================
' 변수명 설명
' ----------------------------------------------------------------------
'
' TargetSheet 작업대상 워크시트, 지정하지 않으면 모든 시트
' WorkResultMessage 작업결과 Message
'
' ======================================================================
Dim sht As Worksheet
Dim rng As Range
Dim strWorkMessage As String
Dim strMessageResult As String
Dim bIsSuccessResult As Boolean
Dim bIsSuccess As Boolean
If TargetSheet Is Nothing Then
' 특정 시트가 지정되지 않음
' 모든 시트를 대상으로 작업
bIsSuccessResult = True
For Each sht In ActiveWorkbook.Worksheets
bIsSuccess = Make_Data(sht, strWorkMessage)
If bIsSuccess Then
Else
' 전체중에서 하나만 실패해도 실패로 기록
bIsSuccessResult = False
End If
' 작업 결과 메시지 누적
strMessageResult = strMessageResult & strWorkMessage
Next sht
Else
' 특정 시트가 지정되었음
' 해당 시트만 작업
bIsSuccessResult = Make_Data(TargetSheet, WorkResultMessage)
End If
Make_Data4Save = bIsSuccessResult
End Function
Public Function Make_Data(sht As Worksheet, WorkMessage As String) As Boolean
Dim rng As Range
Dim strMsg As String
Dim bIsSuccess As Boolean
Set rng = Get_NamedRange("C_Caption", sht)
If rng Is Nothing Then
strMsg = sht.Name & "대상 아님"
bIsSuccess = True
Else
bIsSuccess = Make_CRUD_Data_New(sht, rng, WorkMessage)
If bIsSuccess Then
strMsg = sht.Name & " 성공"
Else
strMsg = sht.Name & " 실패" & vbCr & vbCr & "오류 Message : " & vbCr & WorkMessage
End If
End If
WorkMessage = strMsg
Make_Data = bIsSuccess
End Function
Public Function Make_CRUD_Data(shtCRUD As Worksheet, rngBase As Range, ErrorMessage As String) As Boolean
Dim rng As Range
Dim rngPK As Range
Dim CheckResult As Long
' Base Row
Dim rngKeyBaseColumn As Range
Dim rngKeyBaseRow As Range
Dim rngValueBase As Range
' 기본 대상 전체 영역
Dim rngKeyBaseTargetColumn As Range
Dim rngKeyBaseTargetRow As Range
Dim rngValueBaseTarget As Range
' 실 대상 영역
Dim rngKeyRealTargetColumn As Range
Dim rngKeyRealTargetRow As Range
Dim rngValueRealTarget As Range
' 전체 CRUD 시트 영역의 추출 범위
Dim rngAll As Range
' Key 검사
Dim rngFirstKey As Range
Dim rngKey As Range
Dim rngKey2 As Range
Dim isNamedRangeFlag As Boolean
' 실제 저장 대상 범위 계산
Dim rngRealSaveColumn As Range
Dim rngRealSaveRow As Range
Dim rngRealValue As Range
Dim rngColumn As Range
Dim rngRow As Range
Dim rngColumnKey As Range
Dim rngColKey As Range
Dim rngValue As Range
Dim rngValueKey As Range
Dim rngValueKeyCheck As Range
Dim rngValueResult As Range
Dim rngValue2 As Range
Dim rngValueResult2 As Range
Dim rngValueIntersect As Range
Dim rngCRUDValue As Range
Dim rngCRUDKey As Range
Dim rngTarget As Range
Dim rngKeySource As Range
Dim iSize As Long
Dim rngBlankKey As Range
Dim rngRowKey As Range
Dim rngColumnKeyMerge As Range
Dim rngCopyValue As Range
Dim rngAlreadyAppliedValue As Range
Dim rngAlreadyAppliedValueCheck As Range
Dim bSwapFlag As Boolean
Dim KeyDirection As FirstKey_Direction
On Error GoTo MakeError
' 기본 정보 영역
Set rngKeyBaseColumn = shtCRUD.Range("C7").EntireRow
Set rngKeyBaseRow = shtCRUD.Range("C8").EntireRow
Set rngValueBase = shtCRUD.Range("C9").EntireRow
' 전체 영역 계산
Set rngAll = rngBase.CurrentRegion.EntireColumn.Offset(, 2)
Set rngAll = rngAll.Resize(, rngAll.Columns.Count - 2)
' 기본 대상 영역 추출
Set rngKeyBaseTargetColumn = Application.Intersect(rngKeyBaseColumn, rngAll)
Set rngKeyBaseTargetRow = Application.Intersect(rngKeyBaseRow, rngAll)
Set rngValueBaseTarget = Application.Intersect(rngValueBase, rngAll)
' 실 대상 영역 추출
Set rngKeyRealTargetColumn = Get_SpecialCells(rngKeyBaseTargetColumn, xlCellTypeFormulas, xlErrors + xlLogical + xlNumbers + xlTextValues)
Set rngKeyRealTargetRow = Get_SpecialCells(rngKeyBaseTargetRow, xlCellTypeFormulas, xlErrors + xlLogical + xlNumbers + xlTextValues)
' 값 영역은 수식으로 작성된 부분만 추출하고 상수로 입력된 영역은 맨 마지막에 일괄 처리
Set rngValueRealTarget = Get_SpecialCells(rngValueBaseTarget, xlCellTypeFormulas, xlErrors + xlLogical + xlNumbers + xlTextValues)
' ------------------------------------------------------------
' Key, Data 범위의 유효성 검사 시작
' ------------------------------------------------------------
CheckResult = Check_Key_Value_Range_New(rngFirstKey, _
rngKeyBaseColumn, _
rngKeyBaseRow, _
rngValueBase, _
rngAll, _
rngKeyBaseTargetColumn, _
rngKeyBaseTargetRow, _
rngValueBaseTarget, _
rngKeyRealTargetColumn, _
rngKeyRealTargetRow, _
rngValueRealTarget, _
ErrorMessage, _
iSize, _
KeyDirection)
' 검사 오류 체크
If CheckResult > 0 Then
' 셋팅된 범위에 오류가 있음 - 종료
Make_CRUD_Data = False
Exit Function
End If
' ------------------------------------------------------------
' Key, Data 범위의 유효성 검사 끝
' ------------------------------------------------------------
' ------------------------------------------------------------
' 데이터 생성 시작 - 수식 처리 부분
' ------------------------------------------------------------
If KeyDirection = FirstKey_Direction.Row Then
'
' 첫 번째 Key 방향이 행 방향으로 지정되었음
' 행/열 범위를 서로 치환하여야 함
'
bSwapFlag = Swap_Range(rngKeyRealTargetColumn, rngKeyRealTargetRow)
bSwapFlag = Swap_Range(rngColumnKey, rngRowKey)
' bSwapFlag = Swap_Range(rngKeyRealTargetColumn, rngKeyRealTargetRow)
End If
' 복사될 (저장 대상) 시작 셀 위치 지정
Set rng = rngBase.Offset(1)
' 열 Key Field 영역 순환
For Each rngColumn In rngKeyRealTargetColumn.Range("A1")
' 실제 데이터 영역 계산
Set rngColumnKey = Get_KeyRange(rngColumn, isNamedRangeFlag, rngKeySource)
If isNamedRangeFlag Then
Else
For Each rngColKey In rngColumnKey
If IsError(rngColKey.Value) Then
' 빈 셀, 오류 셀, 값이 없는 셀은 제외
Else
If IsEmpty(rngColKey.Value) Or rngColKey.Value = "" Then
Else
' 이미 처리한 동일한 Key 값을 가지는 대상 Key 찾기
Set rngColumnKeyMerge = Get_Same_KeyRange_Pre(rngColKey, rngColumnKey, KeyDirection)
If rngColumnKeyMerge Is Nothing Then
' 동일한 Key 값을 가지는 대상 Key 찾기
Set rngColumnKeyMerge = Get_Same_KeyRange(rngColKey, rngColumnKey, KeyDirection)
'Key 복사
For Each rngRow In rngKeyRealTargetRow
Set rngCRUDKey = Get_KeyRange(rngRow, isNamedRangeFlag, rngKeySource)
If isNamedRangeFlag Then
Set rngCRUDKey = Get_NamedRange(Mid(rngRow.Formula, 2))
End If
Set rngTarget = Application.Intersect(rng.EntireRow, rngRow.EntireColumn)
' Key 방향 확인
If KeyDirection = FirstKey_Direction.Row Then
' 행 방향으로 지정됨
rngTarget.Resize(iSize).Value = Application.WorksheetFunction.Transpose(rngCRUDKey.Value)
Else
rngTarget.Resize(iSize).Value = rngCRUDKey.Value
End If
Next rngRow
' 행 Key 복사
' 복사될 대상 범위 계산
Set rngTarget = Application.Intersect(rng.EntireRow, rngColumn.EntireColumn)
' Key 방향 확인
If KeyDirection = FirstKey_Direction.Row Then
' 행 방향으로 지정됨
rngTarget.Resize(iSize).Value = Application.WorksheetFunction.Transpose(rngColKey.Value)
Else
rngTarget.Resize(iSize).Value = rngColKey.Value
End If
' 값 복사 시작
' 값을 저장할 대상 범위 순환
' 값 영역이 지정되었는지 검사
If rngValueRealTarget Is Nothing Then
' 데이터 범위가 지정되지 않음
Else
Set rngAlreadyAppliedValue = Nothing
For Each rngValueKey In rngValueRealTarget
If rngColKey.Parent.Name <> rngCRUDKey.Parent.Name Then
' 키 시트가 서로 다름
Else
Set rngRowKey = rngBase
Set rngValueKeyCheck = Get_KeyRange(rngValueKey, isNamedRangeFlag, rngKeySource, rngRowKey)
If isNamedRangeFlag Then
' 이름 정의로 정의된 값
' 복사될 대상 범위 계산
Set rngTarget = Application.Intersect(rng.EntireRow, rngValueKey.EntireColumn)
'-----------------------------------------------------------
' 값 복사 실행
'-----------------------------------------------------------
' 이름 정의된 값이므로 키 방향 확인 불필요함
rngTarget.Resize(iSize).Value = rngValueKey.Value
''' ' Key 방향 확인
''' If KeyDirection = FirstKey_Direction.Row Then
''' ' 행 방향으로 지정됨
''' rngTarget.Resize(iSize).Value = Application.WorksheetFunction.Transpose(rngValueKey.Value)
''' Else
''' rngTarget.Resize(iSize).Value = rngValueKey.Value
''' End If
'-----------------------------------------------------------
Else
' 키 열과 일치하는 실제 값 범위 계산
Set rngValue2 = Application.Intersect(rngColumnKeyMerge.EntireColumn, rngCRUDKey.Resize(iSize).EntireRow)
' 지정된 값 범위가 실제 적용을 위한 데이터 컬럼에 포함되는지 검사
Set rngValueIntersect = Application.Intersect(rngValue2, rngValueKeyCheck)
If rngValueIntersect Is Nothing Then
' 지정되지 않은 범위임
Else
' 복사될 대상 범위 계산
Set rngTarget = Application.Intersect(rng.EntireRow, rngValueKey.EntireColumn)
'-----------------------------------------------------------
' 값 복사 실행
'-----------------------------------------------------------
For Each rngCopyValue In rngValue2.Areas
' 이미 적용한 범위인지 검사하고 적용되지 않은 범위이면 값 복사
Set rngRealValue = Application.Intersect(rngCopyValue, rngValueKeyCheck)
If rngAlreadyAppliedValue Is Nothing Then
' Key 방향 확인
If KeyDirection = FirstKey_Direction.Row Then
' 행 방향으로 지정됨
rngTarget.Resize(iSize, rngRealValue.Columns.Count).Value = Application.WorksheetFunction.Transpose(rngRealValue.Value)
Else
rngTarget.Resize(iSize, rngRealValue.Columns.Count).Value = rngRealValue.Value
End If
Else
Set rngAlreadyAppliedValueCheck = Application.Intersect(rngAlreadyAppliedValue, rngRealValue)
If rngAlreadyAppliedValueCheck Is Nothing Then
' Key 방향 확인
If KeyDirection = FirstKey_Direction.Row Then
' 행 방향으로 지정됨
rngTarget.Resize(iSize, rngRealValue.Columns.Count).Value = Application.WorksheetFunction.Transpose(rngRealValue.Value)
Else
rngTarget.Resize(iSize, rngRealValue.Columns.Count).Value = rngRealValue.Value
End If
End If
End If
Next rngCopyValue
'-----------------------------------------------------------
End If
' 적용된 범위 합침
Set rngAlreadyAppliedValue = Union_Range(rngAlreadyAppliedValue, rngRealValue)
End If
End If
Next rngValueKey
Set rng = rng.Offset(iSize)
End If
End If
End If
End If
Next rngColKey
End If
Next rngColumn
' ------------------------------------------------------------
' 데이터 생성 끝 - 수식 처리 부분
' ------------------------------------------------------------
' ------------------------------------------------------------
' 데이터 생성 시작 - 상수/이름 정의/단일 셀 처리 부분
' ------------------------------------------------------------
' 값 영역 상수 처리
Set rngValueRealTarget = Get_SpecialCells(rngValueBaseTarget, xlCellTypeConstants, xlErrors + xlLogical + xlNumbers + xlTextValues)
' 전체 출력된 건수 계산
Set rng = Get_ResizeBaseRange(rngBase)
iSize = rng.Rows.Count
If rngValueRealTarget Is Nothing Then
' 대상 영역이 없음
Else
For Each rngValue In rngValueRealTarget.Areas
' 값 복사
Call Set_Value(rngBase.Offset(1).EntireRow, rngValue.EntireColumn, iSize, rngValue)
Next rngValue
End If
' 열 키 영역 상수/이름 정의/단일 셀 처리
Call Set_Value_Const(rngBase, rngKeyBaseTargetColumn, iSize)
' 행 키 영역 상수/이름 정의/단일 셀 처리
Call Set_Value_Const(rngBase, rngKeyBaseTargetRow, iSize)
' ------------------------------------------------------------
' 데이터 생성 끝 - 상수/이름 정의/단일 셀 처리 부분
' ------------------------------------------------------------
' ------------------------------------------------------------
' Key 값에 값이 없는 데이터 행 삭제 처리
' ------------------------------------------------------------
Call Clear_NA_Row(shtCRUD, rngAll, rngBase)
' ------------------------------------------------------------
' 모든 데이터 생성 끝
' ------------------------------------------------------------
Make_CRUD_Data = True
ErrorMessage = ""
Exit Function
MakeError:
ErrorMessage = "확인되지 않은 오류입니다." & vbCr & vbCr & _
"오류 코드 : " & Err.Number & vbCr & vbCr & _
"오류 내용 : " & Err.Description
Make_CRUD_Data = False
'Resume
End Function
'
' 수식으로 지정된 데이터 생성
'
Public Function Make_Data4Save_Formula(sht As Worksheet, ErrorMessage As String) As Boolean
Dim shtSource As Range
Dim rngFormulaBase As Range
Dim rngCountBase As Range
Dim rngBase As Range
Dim rngAll As Range
Dim rngFormulaBaseTarget As Range
Dim rngTarget As Range
Dim rng As Range
Dim rngLast As Range
Dim rngUpLast As Range
Dim lastRow As Long
Dim DataCount As Long
On Error GoTo CopyError
Set rngFormulaBase = sht.Range("C10")
Set rngCountBase = sht.Range("A10")
Set rngBase = Get_NamedRange("C_Caption", sht)
' 전체 영역 계산
Set rngAll = rngBase.CurrentRegion.EntireColumn.Offset(, 2)
Set rngAll = rngAll.Resize(, rngAll.Columns.Count - 2)
' 기본 대상 영역 추출
Set rngFormulaBaseTarget = Application.Intersect(rngFormulaBase.EntireRow, rngAll.EntireColumn)
' 데이터 건수를 헤아리기위한 범위의 실제 영역 할당
Set rngTarget = Range(rngCountBase.Formula)
'Set shtSource = rngTarget.Parent
' 전체 열에서 맨 마지막 행 계산
For Each rng In rngTarget
Set rngLast = rngTarget.Parent.Cells(Cells.Rows.Count, rng.Column)
If IsEmpty(rngLast.Value) Then
Set rngUpLast = rngLast.End(xlUp)
lastRow = Application.WorksheetFunction.Max(lastRow, rngUpLast.Row)
Else
lastRow = Cells.Rows.Count
Exit For
End If
Next rng
' 계산된 마지막 행에서 시작행까지의 실제 행의 건수 계산
DataCount = lastRow - rngTarget.Row + 1
' ------------------------------------------------------------
' 1. 데이터 생성 시작
' ------------------------------------------------------------
' ------------------------------------------------------------
' 1.1 수식 복사
' ------------------------------------------------------------
' 수식 복사
rngBase.Offset(1).Resize(DataCount, rngFormulaBaseTarget.Columns.Count).Formula = rngFormulaBaseTarget.Formula
' ------------------------------------------------------------
' 1.2. Key 값에 값이 없는 데이터 행 삭제 처리
' ------------------------------------------------------------
Call Clear_NA_Row(sht, rngAll, rngBase)
' ------------------------------------------------------------
' 1. 데이터 생성 끝
' ------------------------------------------------------------
Make_Data4Save_Formula = True
Exit Function
CopyError:
ErrorMessage = "확인되지 않은 오류입니다." & vbCr & vbCr & _
"오류 코드 : " & Err.Number & vbCr & vbCr & _
"오류 내용 : " & Err.Description
Make_Data4Save_Formula = False
End Function
' Key 영역 계산
Public Function Get_KeyRange(rngKey As Range, isNamedRangeFlag As Boolean, rngKeySource As Range, Optional rngRowKey As Range) As Range
Dim rng As Range
For Each rng In rngKey
If rng.HasFormula Then
' 수식으로 작성되어 있음
If isNamedRange(rng.Formula) Then
' 이름정의로 정의된 값임
isNamedRangeFlag = True
Set rngKeySource = rng
Else
' 셀 참조 범위로 정의되었음
isNamedRangeFlag = False
' 범위 계산
Set Get_KeyRange = Get_Range(rng)
' Set Get_KeyRange = Range(rng.Formula)
Set rngKeySource = rng
If rngRowKey Is Nothing Then
Else
' 삭제 대상 행 선정을 위한 기준 Key 셀 할당
Set rngRowKey = rng
End If
Exit For
End If
End If
Next rng
End Function
' 이름 정의된 영역인지 검사
Public Function isNamedRange(strFormula As String, Optional rngNamed As Range) As Boolean
Dim rng As Range
Set rng = Get_NamedRange(Mid(strFormula, 2))
If rngNamed Is Nothing Then
Else
Set rngNamed = rng
End If
isNamedRange = Not (rng Is Nothing)
End Function
'
' 값 셋팅
'
Public Sub Set_Value(rng1 As Range, rng2 As Range, iSize As Long, rngValue As Range)
Dim rngIntersect As Range
Set rngIntersect = Application.Intersect(rng1.EntireRow, rng2.EntireColumn)
rngIntersect.Resize(iSize).Value = rngValue.Value
End Sub
'
' 행 키 영역 상수/이름 정의/단일 셀 처리
'
Public Sub Set_Value_Const(rngBase As Range, rngKeyBaseTargetRow As Range, iSize As Long)
Dim rng As Range
Dim rngKey As Range
Dim rngRCKey As Range
Dim rngKeySource As Range
Dim isNamedRangeFlag As Boolean
' 행 키 영역 상수/이름 정의/단일 셀 처리
Set rngRCKey = Get_SpecialCells(rngKeyBaseTargetRow, xlCellTypeConstants + xlCellTypeFormulas, xlErrors + xlLogical + xlNumbers + xlTextValues)
If rngRCKey Is Nothing Then
' 대상 영역이 없음
Else
For Each rng In rngRCKey
' Key 범위 계산
Set rngKey = Get_KeyRange(rng, isNamedRangeFlag, rngKeySource)
'
' 이름 정의된 셀, 단일 셀, 상수 셀에 대한 값 복사 처리
'
If isNamedRangeFlag Then
If Range(rng.Formula).Cells.Count = 1 Then
' 이름 정의된 영역, 값 복사
Call Set_Value(rngBase.Offset(1).EntireRow, rng.EntireColumn, iSize, rng)
End If
ElseIf rngKey Is Nothing Then
' 상수 셀 값 복사
Call Set_Value(rngBase.Offset(1).EntireRow, rng.EntireColumn, iSize, rng)
ElseIf rngKey.Cells.Count = 1 Then
' 단일 셀 영역 값 복사
Call Set_Value(rngBase.Offset(1).EntireRow, rng.EntireColumn, iSize, rng)
End If
Next rng
End If
End Sub
'
' 이미 처리된 동일 Key 값을 가진 Key 컬럼 추출
'
Public Function Get_Same_KeyRange_Pre(rngBaseKey As Range, rngWholeKey As Range, KeyDirection As FirstKey_Direction) As Range
Dim rng As Range
Dim rngNewWholeKey As Range
Dim rngSameKey As Range
If KeyDirection = FirstKey_Direction.Column Then
' 처음 호출되는 Key 값인지 확인
If rngBaseKey.Column = rngWholeKey.Column Then
Exit Function
End If
Set rngNewWholeKey = rngWholeKey.Resize(, rngBaseKey.Column - rngWholeKey.Column)
Else
' 처음 호출되는 Key 값인지 확인
If rngBaseKey.Row = rngWholeKey.Row Then
Exit Function
End If
Set rngNewWholeKey = rngWholeKey.Resize(, rngBaseKey.Row - rngWholeKey.Row)
End If
Set rngSameKey = Nothing
If rngNewWholeKey Is Nothing Then
Else
For Each rng In rngNewWholeKey
' Key 값이 같은지 검사
If IsError(rng.Value) Then
' 빈 셀, 오류 셀, 값이 없는 셀은 제외
Else
If IsEmpty(rng.Value) Or rng.Value = "" Then
Else
If rngBaseKey.Value = rng.Value Then
Set rngSameKey = rngBaseKey
Exit For
End If
End If
End If
Next rng
End If
Set Get_Same_KeyRange_Pre = rngSameKey
End Function
'
' 동일 Key 값을 가진 Key 컬럼 추출
'
Public Function Get_Same_KeyRange(rngBaseKey As Range, rngWholeKey As Range, KeyDirection As FirstKey_Direction) As Range
Dim rng As Range
Dim rngNewWholeKey As Range
Dim rngSameKey As Range
If KeyDirection = FirstKey_Direction.Column Then
Set rng = rngWholeKey.Offset(, rngBaseKey.Column - rngWholeKey.Column + 1)
Else
Set rng = rngWholeKey.Offset(, rngBaseKey.Row - rngWholeKey.Row + 1)
End If
Set rngNewWholeKey = Application.Intersect(rng, rngWholeKey)
Set rngSameKey = rngBaseKey
If rngNewWholeKey Is Nothing Then
Else
For Each rng In rngNewWholeKey
' Key 값이 같은지 검사
If IsError(rng.Value) Then
' 빈 셀, 오류 셀, 값이 없는 셀은 제외
Else
If IsEmpty(rng.Value) Or rng.Value = "" Then
Else
If rngBaseKey.Value = rng.Value Then
Set rngSameKey = Union_Range(rngSameKey, rng)
End If
End If
End If
Next rng
End If
Set Get_Same_KeyRange = rngSameKey
End Function
'
' Key, Data 영역에 지정된 참조 범위에 오류가 없는지 검사
'
Public Function Check_Key_Value_Range(rngKeyBaseColumn As Range, _
rngKeyBaseRow As Range, _
rngValueBase As Range, _
rngAll As Range, _
rngKeyBaseTargetColumn As Range, _
rngKeyBaseTargetRow As Range, _
rngValueBaseTarget As Range, _
rngKeyRealTargetColumn As Range, _
rngKeyRealTargetRow As Range, _
rngValueRealTarget As Range, _
CheckErrorMessage As String, _
iSize As Long) As Long
Dim rng As Range
Dim rngFirstKey As Range
Dim rngKey As Range
Dim rngKeySource As Range
Dim isNamedRangeFlag As Boolean
On Error GoTo KeyCheckError
' ------------------------------------------------------------
' Key 범위의 행/열 갯수가 일치하는지 확인
' ------------------------------------------------------------
' >> 열 영역 대상 범위 유효성 검사
' Key 범위 계산
Set rngFirstKey = Get_KeyRange(rngKeyRealTargetColumn, isNamedRangeFlag, rngKeySource)
If isNamedRangeFlag Then
' 이름정의된 영역임 - 검사 안함
Else
If rngFirstKey.Areas.Count > 1 Then
' 키 범위는 다중 범위가 될 수 없음
Set rng = rngFirstKey
Err.Raise 8001
End If
' 첫 번째 Key 열 너비 계산
iSize = rngFirstKey.Columns.Count
For Each rng In rngKeyRealTargetColumn
' Key 범위 계산
Set rngKey = Get_KeyRange(rng, isNamedRangeFlag, rngKeySource)
If isNamedRangeFlag Then
' 이름정의된 영역임 - 검사 안함
Else
If rngKey.Areas.Count > 1 Then
' 키 범위는 다중 범위가 될 수 없음
Err.Raise 8001
End If
' 1. Key 영역의 행 갯수 검사
If rngKey.Rows.Count = 1 Then
' Key 영역의 행의 갯수가 1이므로 키로 적합
Else
' Key 영역이 다중 열임 - 오류
Err.Raise 9001
Exit For
End If
' 2. Key 영역의 시작열 번호와 열의 갯수가 같은지 검사
If rngFirstKey.Column = rngKey.Column Then
If iSize = rngKey.Columns.Count Then
Else
' Key 영역이 서로 다름 - 오류
Err.Raise 9002
Exit For
End If
End If
End If
Next rng
End If
' >> 행 영역 대상 범위 유효성 검사
' Key 범위 계산
Set rngFirstKey = Get_KeyRange(rngKeyRealTargetRow, isNamedRangeFlag, rngKeySource)
If isNamedRangeFlag Then
' 이름정의된 영역임 - 검사 안함
Else
If rngFirstKey.Areas.Count > 1 Then
' 키 범위는 다중 범위가 될 수 없음
Set rng = rngFirstKey
Err.Raise 8002
End If
' 첫 번째 Key 행 건수 계산
iSize = rngFirstKey.Rows.Count
For Each rng In rngKeyRealTargetRow
' Key 범위 계산
Set rngKey = Get_KeyRange(rng, isNamedRangeFlag, rngKeySource)
If isNamedRangeFlag Then
' 이름정의된 영역임 - 검사 안함
Else
If rngKey.Areas.Count > 1 Then
' 키 범위는 다중 범위가 될 수 없음
Err.Raise 8002
End If
' 1. Key 영역의 행 갯수 검사
If rngKey.Columns.Count = 1 Then
' Key 영역의 행의 갯수가 1이므로 키로 적합
Else
' Key 영역이 다중 열임 - 오류
Err.Raise 9005
Exit For
End If
' 2. Key 영역의 시작열 번호와 열의 갯수가 같은지 검사
If rngFirstKey.Row = rngKey.Row Then
If iSize = rngKey.Rows.Count Then
Else
' Key 영역이 서로 다름 - 오류
Err.Raise 9006
Exit For
End If
End If
End If
Next rng
If rngValueRealTarget Is Nothing Then
' 데이터 범위가 지정되지 않음
Else
' 값 영역 검사
For Each rng In rngValueRealTarget
' Key 범위 계산
Set rngKey = Get_KeyRange(rng, isNamedRangeFlag, rngKeySource)
If isNamedRangeFlag Then
' 이름정의된 영역임 - 검사 안함
Else
' 1. 행의 갯수가 같은지 검사
If iSize = rngKey.Rows.Count Then
Else
' 행의 갯수가 다름 - 오류
Err.Raise 9004
End If
End If
Next rng
End If
End If
' ------------------------------------------------------------
' Key 범위의 행/열 갯수가 일치하는지 확인 끝
' ------------------------------------------------------------
CheckErrorMessage = ""
Check_Key_Value_Range = 0
Exit Function
KeyCheckError:
Select Case Err.Number
Case 8001, 9001
CheckErrorMessage = "열 Key 범위에 다중 범위가 지정되었습니다."
Case 8002, 9005
CheckErrorMessage = "행 Key 범위에 다중 범위가 지정되었습니다."
Case 8003
CheckErrorMessage = "데이터 범위에 다중 범위가 지정되었습니다."
Case 8004
CheckErrorMessage = "열 Key 범위의 행이 1개의 행이 아닙니다.(2개 이상 지정)"
Case 8005
CheckErrorMessage = "행 Key 범위의 열이 1개의 열이 아닙니다.(2개 이상 지정)"
Case 8006
CheckErrorMessage = "열 Key가 행 방향으로 지정되었음에도 행 Key 범위의 행이 1개의 행이 아닙니다.(2개 이상 지정)"
Case 9002
CheckErrorMessage = "열 Key 영역이 서로 다릅니다."
Case 9006
CheckErrorMessage = "행 Key 영역이 서로 다릅니다."
Case 9004
CheckErrorMessage = "데이터 영역의 행 높이와 행 Key의 행 높이가 서로 다릅니다."
Case Else
CheckErrorMessage = "확인되지 않은 오류입니다." & vbCr & vbCr & _
"오류 코드 : " & Err.Number & vbCr & vbCr & _
"오류 내용 : " & Err.Description
If Err.Number = 1004 Then
Select Case rng.Text
Case "#NULL!", "#DIV/0!", "#REF!", "#NAME?", "#NUM!", "#N/A", "#GETTING_DATA"
CheckErrorMessage = "(" & rng.Text & " 오류) - 지정한 범위가 잘못되었습니다."
End Select
End If
End Select
Check_Key_Value_Range = Err.Number
CheckErrorMessage = "시트 : " & rng.Parent.Name & vbCr & _
"셀 : " & rng.Address & vbCr & vbCr & CheckErrorMessage
End Function
'
' Key, Data 영역에 지정된 참조 범위에 오류가 없는지 검사
'
Public Function Check_Key_Value_Range_New(rngFirstColumnKey As Range, _
rngKeyBaseColumn As Range, _
rngKeyBaseRow As Range, _
rngValueBase As Range, _
rngAll As Range, _
rngKeyBaseTargetColumn As Range, _
rngKeyBaseTargetRow As Range, _
rngValueBaseTarget As Range, _
rngKeyRealTargetColumn As Range, _
rngKeyRealTargetRow As Range, _
rngValueRealTarget As Range, _
CheckErrorMessage As String, _
iSize As Long, _
KeyDirection As FirstKey_Direction) As Long
Dim rng As Range
Dim rngFirstKey As Range
Dim rngKey As Range
Dim isNamedRangeFlag As Boolean
Dim ErrorCode As Long
Dim CheckKey As Boolean
Dim DataSize As Long
Dim RCSize As Long
Dim rngKeySource As Range
Dim FirstKeyDirection As FirstKey_Direction
On Error GoTo KeyCheckError
' ------------------------------------------------------------
' Key 범위의 행/열 갯수가 일치하는지 확인
' ------------------------------------------------------------
' >> 열 영역 대상 범위 유효성 검사
' Key 범위 계산
Set rngFirstKey = Get_KeyRange(rngKeyRealTargetColumn, isNamedRangeFlag, rngKeySource)
If isNamedRangeFlag Then
' 이름정의된 영역임 - 검사 안함
Else
If rngFirstKey.Areas.Count > 1 Then
' 키 범위는 다중 범위가 될 수 없음
Set rng = rngFirstKey
ErrorCode = 8001
Err.Raise ErrorCode
End If
If rngFirstKey.Rows.Count = 1 Or rngFirstKey.Columns.Count = 1 Then
' Key 범위는 하나의 행 또는 하나의 열이므로 사용가능 Key
Else
' 키 범위는 다중 범위가 될 수 없음
Set rng = rngFirstKey
ErrorCode = 8004
Err.Raise ErrorCode
End If
' 첫 번째 Key 열 너비 계산
iSize = rngFirstKey.Columns.Count
If iSize > 1 Then
' 컬럼 Key 영역의 첫 번째 Key가 다중 열임
' Key 방향 결정
FirstKeyDirection = FirstKey_Direction.Column
iSize = rngFirstKey.Columns.Count
'DataSize = iSize
CheckKey = Check_Column_Key(rngKeyRealTargetColumn, rngFirstKey, iSize, ErrorCode)
Set rngFirstColumnKey = rngFirstKey
Else
' 컬럼 Key 영역의 첫 번째 Key가 다중 행임
' Key 방향 결정
FirstKeyDirection = FirstKey_Direction.Row
' 열 너비의 크기를 행 높이의 크기로 변경
iSize = rngFirstKey.Rows.Count
DataSize = iSize
CheckKey = Check_Row_Key(rngKeyRealTargetColumn, rngFirstKey, iSize, ErrorCode)
End If
If CheckKey Then
Else
Set rng = rngKeySource
Err.Raise ErrorCode
End If
End If
' >> 행 영역 대상 범위 유효성 검사
' Key 범위 계산
Set rngFirstKey = Get_KeyRange(rngKeyRealTargetRow, isNamedRangeFlag, rngKeySource)
If isNamedRangeFlag Then
' 이름정의된 영역임 - 검사 안함
Else
If rngFirstKey.Areas.Count > 1 Then
' 키 범위는 다중 범위가 될 수 없음
Set rng = rngFirstKey
ErrorCode = 8002
Err.Raise ErrorCode
End If
' 첫 번째 Key 행 건수 계산
If FirstKeyDirection = FirstKey_Direction.Column Then
If rngFirstKey.Columns.Count = 1 Then
' Key 범위는 하나의 열이므로 사용가능 Key
iSize = rngFirstKey.Rows.Count
DataSize = iSize
CheckKey = Check_Row_Key(rngKeyRealTargetRow, rngFirstKey, iSize, ErrorCode)
Else
' 키 범위는 다중 범위가 될 수 없음 - 오류
Set rng = rngFirstKey
ErrorCode = 8005
Err.Raise ErrorCode
End If
Else
If rngFirstKey.Rows.Count = 1 Then
' Key 범위는 하나의 열이므로 사용가능 Key
iSize = rngFirstKey.Columns.Count
DataSize = iSize
CheckKey = Check_Column_Key(rngKeyRealTargetRow, rngFirstKey, iSize, ErrorCode)
Set rngFirstColumnKey = rngFirstKey
Else
' 키 범위는 다중 범위가 될 수 없음 - 오류
Set rng = rngFirstKey
ErrorCode = 8006
Err.Raise ErrorCode
End If
End If
If CheckKey Then
Else
Set rng = rngKeySource
Err.Raise ErrorCode
End If
End If
If rngValueRealTarget Is Nothing Then
' 데이터 범위가 지정되지 않음
Else
' 데이터의 크기가 지정되지 않은 경우에는 크기 검사 생략
' 실제 Key 를 지정하지 않아도 되는 경우로 판단
If DataSize > 0 Then
' 값 영역 검사
For Each rng In rngValueRealTarget
' Key 범위 계산
Set rngKey = Get_KeyRange(rng, isNamedRangeFlag, rngKeySource)
If isNamedRangeFlag Then
' 이름정의된 영역임 - 검사 안함
Else
' 1. 첫 번째 Key 방향 확인
If FirstKeyDirection = FirstKey_Direction.Column Then
RCSize = rngKey.Rows.Count
Else
RCSize = rngKey.Columns.Count
End If
' 1.1 행 또는 열의 갯수가 같은지 검사
If DataSize = RCSize Then
Else
' 행의 갯수가 다름 - 오류
ErrorCode = 9004
Err.Raise ErrorCode
End If
End If
Next rng
End If
End If
' ------------------------------------------------------------
' Key 범위의 행/열 갯수가 일치하는지 확인 끝
' ------------------------------------------------------------
CheckErrorMessage = ""
Check_Key_Value_Range_New = 0
KeyDirection = FirstKeyDirection
Exit Function
KeyCheckError:
Select Case Err.Number
Case 8001, 9001
CheckErrorMessage = "열 Key 범위에 다중 범위가 지정되었습니다."
Case 8002, 9005
CheckErrorMessage = "행 Key 범위에 다중 범위가 지정되었습니다."
Case 8003
CheckErrorMessage = "데이터 범위에 다중 범위가 지정되었습니다."
Case 8004
CheckErrorMessage = "열 Key 범위의 행이 1개의 행이 아닙니다.(2개 이상 지정)"
Case 8005
CheckErrorMessage = "행 Key 범위의 열이 1개의 열이 아닙니다.(2개 이상 지정)"
Case 8006
CheckErrorMessage = "열 Key가 행 방향으로 지정되었음에도 행 Key 범위의 행이 1개의 행이 아닙니다.(2개 이상 지정)"
Case 9002
CheckErrorMessage = "열 Key 영역이 서로 다릅니다."
Case 9006
CheckErrorMessage = "행 Key 영역이 서로 다릅니다."
Case 9004
CheckErrorMessage = "데이터 영역의 행 높이와 행 Key의 행 높이가 서로 다릅니다."
Case Else
CheckErrorMessage = "확인되지 않은 오류입니다." & vbCr & vbCr & _
"오류 코드 : " & Err.Number & vbCr & vbCr & _
"오류 내용 : " & Err.Description
If Err.Number = 1004 Then
Select Case rng.Text
Case "#NULL!", "#DIV/0!", "#REF!", "#NAME?", "#NUM!", "#N/A", "#GETTING_DATA"
CheckErrorMessage = "(" & rng.Text & " 오류) - 지정한 범위가 잘못되었습니다."
End Select
End If
End Select
Check_Key_Value_Range_New = Err.Number
KeyDirection = FirstKeyDirection
CheckErrorMessage = "시트 : " & rng.Parent.Name & vbCr & _
"셀 : " & rng.Address & vbCr & vbCr & CheckErrorMessage
End Function
Public Function Check_Column_Key(rngKeyRealTargetColumn As Range, rngFirstKey As Range, iSize As Long, ErrorCode As Long) As Boolean
Dim rng As Range
Dim rngKey As Range
Dim rngKeySource As Range
Dim isNamedRangeFlag As Boolean
' 오류 없음 설정
ErrorCode = 0
' Key 범위를 순환하면서 오류 체크
For Each rng In rngKeyRealTargetColumn
' Key 범위 계산
Set rngKey = Get_KeyRange(rng, isNamedRangeFlag, rngKeySource)
If isNamedRangeFlag Then
' 이름정의된 영역임 - 검사 안함
Else
If rngKey.Areas.Count > 1 Then
' 키 범위는 다중 범위가 될 수 없음
ErrorCode = 8001
Exit For
End If
' 1. Key 영역의 행 갯수 검사
If rngKey.Rows.Count = 1 Then
' Key 영역의 행의 갯수가 1이므로 키로 적합
Else
' Key 영역이 다중 열임 - 오류
ErrorCode = 9001
Exit For
End If
' 2. Key 영역의 시작열 번호와 열의 갯수가 같은지 검사
If rngFirstKey.Column = rngKey.Column Then
If iSize = rngKey.Columns.Count Then
Else
' Key 영역이 서로 다름 - 오류
ErrorCode = 9002
Exit For
End If
End If
End If
Next rng
Check_Column_Key = (ErrorCode = 0)
End Function
Public Function Check_Row_Key(rngKeyRealTargetRow As Range, rngFirstKey As Range, iSize As Long, ErrorCode As Long) As Boolean
Dim rng As Range
Dim rngKey As Range
Dim rngKeySource As Range
Dim isNamedRangeFlag As Boolean
' 오류 없음 설정
ErrorCode = 0
For Each rng In rngKeyRealTargetRow
' Key 범위 계산
Set rngKey = Get_KeyRange(rng, isNamedRangeFlag, rngKeySource)
If isNamedRangeFlag Then
' 이름정의된 영역임 - 검사 안함
Else
If rngKey.Areas.Count > 1 Then
' 키 범위는 다중 범위가 될 수 없음
ErrorCode = 8002
Exit For
End If
' 1. Key 영역의 행 갯수 검사
If rngKey.Columns.Count = 1 Then
' Key 영역의 행의 갯수가 1이므로 키로 적합
Else
' Key 영역이 다중 열임 - 오류
ErrorCode = 9005
Exit For
End If
' 2. Key 영역의 시작열 번호와 열의 갯수가 같은지 검사
If rngFirstKey.Row = rngKey.Row Then
If iSize = rngKey.Rows.Count Then
Else
' Key 영역이 서로 다름 - 오류
ErrorCode = 9006
Exit For
End If
End If
End If
Next rng
Check_Row_Key = (ErrorCode = 0)
End Function
Public Function Check_Exists_Sheet(arrSheetList As Variant, strMsg As String) As Boolean
Dim i As Integer
Dim sht As Worksheet
Check_Exists_Sheet = True
' 대상 시트가 있는지 확인
For i = 0 To UBound(arrSheetList)
' 작업 대상 워크시트 확인
Set sht = Get_WorkSheet(CStr(arrSheetList(i)))
If sht Is Nothing Then
' 대상 워크시트명이 잘못되었음
' 오류 - 처리 종료
Check_Exists_Sheet = False
strMsg = strMsg & "시트명 : " & arrSheetList(i) & vbCr
End If
Next i
If Check_Exists_Sheet Then
Else
strMsg = "오류 : 대상 워크시트가 없습니다." & vbCr & vbCr & strMsg
End If
End Function
'
' 생성된 데이터중 PK 에 값이 없는 행은 삭제
'
Public Sub Clear_NA_Row(shtCRUD As Worksheet, rngAll As Range, rngBase As Range)
Dim rngKey As Range
Dim rngPK As Range
Dim rng As Range
Dim rngBlankKey As Range
Dim rngErrorKey As Range
Dim rngValueKeyCheck As Range
Dim rngDeleteRow As Range
Set rngValueKeyCheck = Get_ResizeBaseRange(rngBase)
' ------------------------------------------------------------
' 생성 결과에서 데이터 범위 지정에 빈 셀에 생성된 값 지움 처리 시작
' ------------------------------------------------------------
' 삭제 대상 선정을 위한 기준 Key 값 할당
''''' Set rngValue = Get_SpecialCells(rngValueBaseTarget, xlCellTypeBlanks)
'''''
''''' If rngValue Is Nothing Then
''''' Else
''''' For Each rng In rngValue
''''' If IsEmpty(rng.Offset(-2).Value) Then
''''' If IsEmpty(rng.Offset(-1).Value) Then
''''' ' Key 값과 데이터 지정 범위가 모두 빈 셀임
''''' ' 생성된 결과에서 지움
'''''
''''' ' 자동설정하는 시스템 날짜 형식인지 검사
''''' If UCase(rng.Offset(8).Value) = "S" Then
''''' ' 자동 설정하는 부분이므로 대상아님
''''' Else
''''' ' 교점 계산
''''' Set rngTarget = Application.Intersect(rng.EntireColumn, rngValueKeyCheck.EntireRow)
''''' If rngTarget Is Nothing Then
''''' Else
''''' ' 지음
''''' rngTarget.ClearContents
''''' End If
''''' End If
''''' End If
''''' End If
''''' Next rng
''''' End If
' ------------------------------------------------------------
' 생성 결과에서 데이터 범위 지정에 빈 셀에 생성된 값 지움 처리 끝
' ------------------------------------------------------------
' ------------------------------------------------------------
' 생성결과에서 빈 행은 삭제 처리 시작
' 행 저장 여부 판단을 위한 키 영역에 값이 없으므로 저장 대상이 아니므로 삭제 처리 해야 함
' ------------------------------------------------------------
' 삭제 대상 선정을 위한 기준 Key 값 할당
Set rngKey = shtCRUD.Range("D16").Resize(, rngAll.Columns.Count)
For Each rng In rngKey
If UCase(rng.Value) = "P" Then
' PK 부분만 추출
Set rngPK = Union_Range(rngPK, rng)
End If
Next rng
If rngPK Is Nothing Then
Else
Set rngKey = Application.Intersect(rngValueKeyCheck.EntireRow, rngPK.EntireColumn)
' Balnk 셀 검사
Set rngBlankKey = Get_SpecialCells(rngKey, xlCellTypeBlanks, xlErrors)
' 오류 셀 검사
Set rngErrorKey = Get_SpecialCells(rngKey, xlCellTypeConstants + xlCellTypeFormulas, xlErrors)
' 불필요한 키 삭제
Set rngDeleteRow = Union_Range(rngBlankKey, rngErrorKey)
If rngDeleteRow Is Nothing Then
Else
Set rng = Application.Intersect(rngDeleteRow.Range("A1").EntireColumn, rngDeleteRow.EntireRow)
rng.EntireRow.Delete
End If
End If
' ------------------------------------------------------------
' 생성결과에서 빈 행은 삭제 처리 끝
' 행 저장 여부 판단을 위한 키 영역에 값이 없으므로 저장 대상이 아니므로 삭제 처리 해야 함
' ------------------------------------------------------------
End Sub
'
' 행,열,데이터 영역에 지정된 값이 없는지 검사
' 값이 있는 경우만 처리
' >> 없으면 고정 또는 별도의 처리를 하도록 설정한 것으로 판단
'
Public Function Check_Key_Data(arrSheetList As Variant, strNewSheetList As String, bNeedMakeData As Boolean, strMsg As String) As Boolean
Dim i As Integer
Dim strSheet As String
Dim strColumn As String
Dim strRow As String
Dim strData As String
Dim strFormula As String
Dim sht As Worksheet
Dim rngBase As Range
Dim rngAll As Range
Dim rngKeyBaseColumn As Range
Dim rngKeyBaseRow As Range
Dim rngValueBase As Range
Dim rngFormulaBase As Range
' 기본 대상 전체 영역
Dim rngKeyBaseTargetColumn As Range
Dim rngKeyBaseTargetRow As Range
Dim rngValueBaseTarget As Range
Dim rngFormulaBaseTarget As Range
Dim rngCheckColumn As Range
Dim rngCheckRow As Range
Dim rngCheckData As Range
Dim rngCheckFormula As Range
' 결과 성공, 자동생성 필요 flag 셋팅
Check_Key_Data = True
bNeedMakeData = False
For i = 0 To UBound(arrSheetList)
' 작업 대상 시트
Set sht = Worksheets(arrSheetList(i))
' Base 셀 확인
Set rngBase = Get_NamedRange("C_Caption", sht)
' 기본 정보 영역
Set rngKeyBaseColumn = sht.Range("C7").EntireRow
Set rngKeyBaseRow = sht.Range("C8").EntireRow
Set rngValueBase = sht.Range("C9").EntireRow
Set rngFormulaBase = sht.Range("C10").EntireRow
' 전체 영역 계산
Set rngAll = rngBase.CurrentRegion.EntireColumn.Offset(, 2)
Set rngAll = rngAll.Resize(, rngAll.Columns.Count - 2)
' 기본 대상 영역 추출
Set rngKeyBaseTargetColumn = Application.Intersect(rngKeyBaseColumn, rngAll)
Set rngKeyBaseTargetRow = Application.Intersect(rngKeyBaseRow, rngAll)
Set rngValueBaseTarget = Application.Intersect(rngValueBase, rngAll)
Set rngFormulaBaseTarget = Application.Intersect(rngFormulaBase, rngAll)
' Column Key,Row Key, Data 범위에서 빈 셀이 아닌 모든 값 추출
Set rngCheckColumn = Get_SpecialCells(rngKeyBaseTargetColumn, xlCellTypeConstants + xlCellTypeFormulas, xlErrors + xlLogical + xlNumbers + xlTextValues)
Set rngCheckRow = Get_SpecialCells(rngKeyBaseTargetRow, xlCellTypeConstants + xlCellTypeFormulas, xlErrors + xlLogical + xlNumbers + xlTextValues)
Set rngCheckData = Get_SpecialCells(rngValueBaseTarget, xlCellTypeConstants + xlCellTypeFormulas, xlErrors + xlLogical + xlNumbers + xlTextValues)
Set rngCheckFormula = Get_SpecialCells(rngFormulaBaseTarget, xlCellTypeConstants + xlCellTypeFormulas, xlErrors + xlLogical + xlNumbers + xlTextValues)
' 값 존재 여부 확인
strColumn = Get_ExistsValue(rngCheckColumn)
strRow = Get_ExistsValue(rngCheckRow)
strData = Get_ExistsValue(rngCheckData)
strFormula = Get_ExistsValue(rngCheckFormula)
If rngCheckFormula Is Nothing Then
' 수식 지정 범위에 지정된 수식이 없음
' key, Data 영역에 대한 검사
If rngCheckRow Is Nothing Then
' 행 Key 범위에 값이 없음
If rngCheckColumn Is Nothing Then
' 열 Key 범위에 값이 없음
If rngCheckData Is Nothing Then
' 데이터 자동 생성이 필요없음
strMsg = strMsg & "시트명 : " & sht.Name & " - 자동생성 필요 없음" & vbCr & vbCr
Else
' 데이터 범위에 지정된 값이 있음
' 오류
Check_Key_Data = False
strMsg = strMsg & "시트명 : " & sht.Name & vbCr & _
"오류(원인) : 행 Key 영역 : " & strRow & " ,열 Key 영역 : " & strColumn & ", 데이터 영역 : " & strData & vbCr & vbCr
End If
Else
' 행 Key 범위에 지정된 값이 있음
' 오류
Check_Key_Data = False
strMsg = strMsg & "시트명 : " & sht.Name & vbCr & _
"오류(원인) : 행 Key 영역 : " & strRow & " ,열 Key 영역 : " & strColumn & ", 데이터 영역 : " & strData & vbCr & vbCr
End If
Else
If rngCheckColumn Is Nothing Then
' 열 Key 범위에 지정된 값이 없음
' 오류
Check_Key_Data = False
strMsg = strMsg & "시트명 : " & sht.Name & vbCr & _
"오류(원인) : 행 Key 영역 : " & strRow & " ,열 Key 영역 : " & strColumn & ", 데이터 영역 : " & strData & vbCr & vbCr
Else
If rngCheckData Is Nothing Then
' 데이터 범위에 지정된 값이 없음
' 오류
Check_Key_Data = False
strMsg = strMsg & "시트명 : " & sht.Name & vbCr & _
"오류(원인) : 행 Key 영역 : " & strRow & " ,열 Key 영역 : " & strColumn & ", 데이터 영역 : " & strData & vbCr & vbCr
Else
' 자동 생성이 필요함
bNeedMakeData = True
strSheet = strSheet & sht.Name & ","
strMsg = strMsg & "시트명 : " & sht.Name & " - 자동생성 필요함" & vbCr & vbCr
End If
End If
End If
Else
' 수식 지정 범위에 지정된 수식이 있음
' Key, Data 영역에 지정된 항목이 있는지 검사
If rngCheckColumn Is Nothing And rngCheckRow Is Nothing And rngCheckData Is Nothing Then
' 아무것도 지정되지 않음
' 수식 복사가 필요함 - 시트명에 FLAG 추가
bNeedMakeData = True
strSheet = strSheet & sht.Name & "[|][FORMULA],"
Else
Check_Key_Data = False
strMsg = strMsg & "시트명 : " & sht.Name & vbCr & _
"오류(원인) : 수식 영역과 Key/Data 영역이 동시에 지정되었음." & vbCr & vbCr
End If
End If
Next i
If strSheet = "" Then
Else
strNewSheetList = Left(strSheet, Len(strSheet) - 1)
End If
End Function
'
' 값 존재여부 결과 리턴
'
Public Function Get_ExistsValue(rng As Range) As String
If rng Is Nothing Then
Get_ExistsValue = "값 없음"
Else
Get_ExistsValue = "값 있음"
End If
End Function
'
' 숫자 단위 셋팅
'
' 2017-08-31
'
'
Public Function Set_Numeric_Unit(strSheetName As String, strMsg As String) As Boolean
Dim rng As Range
Dim rngUnitBase As Range
Dim rngBase As Range
Dim rngNumeric As Range
Dim rngUnit As Range
Dim rngAll As Range
Dim rngDataBody As Range
Dim rngDataBodyWhole As Range
Dim rngApply As Range
Dim bSuccess As Boolean
Dim shtCRUD As Worksheet
' 작업 대상 시트
Set shtCRUD = ActiveWorkbook.Worksheets(strSheetName)
' BASE CELL 계산
Set rngBase = Get_NamedRange("C_Caption", shtCRUD)
' 전체 영역 계산
Set rngAll = rngBase.CurrentRegion.EntireColumn.Offset(, 2)
Set rngAll = rngAll.Resize(, rngAll.Columns.Count - 2)
' 숫자 단위 정의 행
Set rngUnitBase = shtCRUD.Range("C11").EntireRow
' 기본 대상 영역 추출
Set rngUnit = Application.Intersect(rngUnitBase, rngAll)
' 단위가 숫자로 지정된 셀 추출
Set rngNumeric = Get_SpecialCells(rngTarget:=rngUnit, CellType:=xlCellTypeFormulas + xlCellTypeConstants, CellValue:=xlNumbers)
If rngNumeric Is Nothing Then
' 단위가 지정된 셀이 없음
Set_Numeric_Unit = True
Exit Function
End If
On Error GoTo Err_UnitConvert
' 데이터 전체 영역계산
Set rngDataBodyWhole = rngBase.CurrentRegion
' 실제 데이터 범위만 계산
With rngDataBodyWhole
Set rngDataBody = .Offset(rngBase.Row - .Row + 1).Resize(.Rows.Count - rngBase.Row + .Row - 1)
End With
bSuccess = True
' 단위 적용
For Each rng In rngNumeric
Set rngApply = Application.Intersect(rngDataBody, rng.EntireColumn)
If rngApply Is Nothing Then
bSuccess = False
Exit For
End If
' 단위 복사
rng.Copy
' 단위 곱하기로 붙여넣기
rngApply.PasteSpecial Paste:=xlPasteFormulas, Operation:=xlPasteSpecialOperationMultiply
Next rng
Set_Numeric_Unit = bSuccess
Exit Function
'
' 단위 변환 오류
'
Err_UnitConvert:
strMsg = Err.Description
Set_Numeric_Unit = False
Err.Clear
End Function
'
' 저장 사전 체크
'
Public Function Check_Before_Save(strMsg As String) As Boolean
Dim shtStatus As Worksheet
Dim rngStatus As Range
Dim strDSName As String
' ===============================
' STEP1 : 사업부 버전 상태 확인
' ===============================
Set shtStatus = ActiveWorkbook.Worksheets("STATUS")
' 현재 상태 데이터 셋 조회
strDSName = "DS_VERSION_STATUS"
Call Refresh_DataSet(strDSName)
' 상태 결과 셀
Set rngStatus = shtStatus.Range("B2")
Select Case rngStatus.Value
Case "GC061030" ' 확정요청
strMsg = "사업부버젼이 확정요청 상태입니다."
Call ShowMessage(strPrompt:=strMsg, Button:=vbInformation, strTitle:="저장 불가")
Check_Before_Save = False
Exit Function
Case "GC061050" ' 확정
strMsg = "사업부버젼이 확정 상태입니다."
Call ShowMessage(strPrompt:=strMsg, Button:=vbInformation, strTitle:="저장 불가")
Check_Before_Save = False
Exit Function
Case Else
' STEP2 로 계속 진행
End Select
' ===============================
' STEP2 : 사업부 버전 정보 등록
' ===============================
' 사업부 버전 정보 등록
strDSName = "DS_SAVE_VERSION_INFO"
Call Refresh_DataSet(strDSName)
' 처리 결과 결과 셀
Set rngStatus = shtStatus.Range("D1")
If rngStatus.Value = "1" Then
' 성공
' STEP3 로 계속 진행
Else
' 실패
' 실패 원인 메시지
strMsg = rngStatus.Offset(, 1).Value
Call ShowMessage(strPrompt:=strMsg, Button:=vbInformation, strTitle:="저장 불가")
Check_Before_Save = False
Exit Function
End If
' ==================================
' STEP3 : 사업부 계획 이력 정보 등록
' ==================================
' 사업부 버전 정보 등록
strDSName = "DS_SAVE_VERSION_HISTORY"
Call Refresh_DataSet(strDSName)
' 처리 결과 결과 셀
Set rngStatus = shtStatus.Range("G1")
If rngStatus.Value = "1" Then
' 성공
' 저장 처리 진행
Check_Before_Save = True
Else
' 실패
' 실패 원인 메시지
strMsg = rngStatus.Offset(, 1).Value
Call ShowMessage(strPrompt:=strMsg, Button:=vbInformation, strTitle:="저장 불가")
Check_Before_Save = False
End If
End Function
Sub ddddd()
Dim rngw As Range
Dim rng As Range
Dim rngb As Range
Set rngb = Range("d19")
Set rngw = rngb.CurrentRegion
With rngw
Set rng = .Offset(rngb.Row - .Row + 1).Resize(.Rows.Count - rngb.Row + .Row - 1)
End With
Debug.Print rng.Address
End Sub
모듈명 : m_Set_Formula
Option Explicit
'
' 기본 수식 및 서식 적용 처리
'
Public Function Set_Default_Format_Formula(sht As Worksheet, SkipBlank As Boolean) As Boolean
' ======================================================================
' 변수명 설명
' ----------------------------------------------------------------------
'
' sht 작업대상 워크시트
' SkipBlank 수식을 복사할 때 빈 셀은 제외할 것인지 설정, 기본값은 True 이고 빈 셀은 제외함
'
' ======================================================================
Dim rngRealTarget As Range
Dim rngDefineColumn As Range
Dim rngDefault As Range
Dim rng As Range
Dim rngLoop As Range
Dim strFormula As String
' 입력 대상 정의 기본 범위 설정
Set rngDefineColumn = Get_NamedRange("_Def_Format_Formula_Col_", sht)
If rngDefineColumn Is Nothing Then
' 이름 정의가 없음...
' 정상 처리로 리턴
Set_Default_Format_Formula = True
Exit Function
End If
For Each rng In rngDefineColumn
If IsEmpty(rng.Value) Then
' 빈 셀 검사
Else
' 실제 대상 범위
strFormula = Mid(rng.Formula, 2)
Set rngRealTarget = Get_FormulaRange_Unit(strFormula, sht)
If rngRealTarget Is Nothing Then
' 참조 영역 주소 반환 오류
Set_Default_Format_Formula = False
Exit Function
End If
If rngRealTarget.Parent.Name <> sht.Name Then
' 작업 대상 워크시트가 서로 다름
' 백업시트에서 수식 복구
For Each rngLoop In rngRealTarget.Areas
rngLoop.Copy Destination:=sht.Range(rngLoop.Address)
Next rngLoop
Else
For Each rngLoop In rngRealTarget.Areas
' 적용할 수식/포맷 정의 범위 계산
Set rngDefault = Application.Intersect(rng.EntireRow, rngLoop.EntireColumn)
' 수식/포맷을 실제 대상 범위에 복사
rngDefault.Copy
rngLoop.PasteSpecial Paste:=xlPasteFormulas, SkipBlanks:=SkipBlank
rngLoop.PasteSpecial Paste:=xlPasteFormats
Next rngLoop
End If
End If
Next rng
Set_Default_Format_Formula = True
End Function
'
' 자동 범위 확장 수식 및 서식 적용 처리
'
Public Function Set_Auto_Expand_Format_Formula(sht As Worksheet, _
SkipBlank As Boolean, _
ExistAuto As Boolean, _
VerStatus As Boolean) As Boolean
' ======================================================================
' 변수명 설명
' ----------------------------------------------------------------------
'
' sht 작업대상 워크시트
' SkipBlank 수식을 복사할 때 빈 셀은 제외할 것인지 설정, 기본값은 True 이고 빈 셀은 제외함
' ExistAuto 자동확장 이름 정의가 있는지 확인하기 위한 Flag
' VerStatus 버전 마감 상태
'
' ======================================================================
Dim rngRealTarget As Range
Dim rngDefineColumn As Range
Dim rngDefault As Range
Dim rng As Range
Dim rngLoop As Range
Dim rngLoopTarget As Range
Dim rngApplyTarget As Range
Dim rngSource As Range
Dim rngBeforeResult As Range
Dim strFormula As String
Dim iRowHeight As Long
Dim iColumnWidth As Long
Dim iRowCount As Long
' 입력 대상 정의 기본 범위 설정
Set rngDefineColumn = Get_NamedRange("_Def_Auto_Expand_Col_", sht)
If rngDefineColumn Is Nothing Then
ExistAuto = False
Set_Auto_Expand_Format_Formula = True
Exit Function
End If
' 마감된 버전이 아니면 입력 구간 스타일 설정
Call Set_Input_Style("DEFAULT", sht)
If VerStatus Then
' 마감된 버전이 아니면 입력 구간 스타일 설정
Call Set_Input_Style("INPUT", sht)
End If
ExistAuto = True
For Each rng In rngDefineColumn
If IsEmpty(rng.Value) Then
' 빈 셀 검사
Else
' -----------------------------------------------
' 수식 복사를 위한 기초 범위 계산
' -----------------------------------------------
' 실제 대상 범위
strFormula = Mid(rng.Formula, 2)
Set rngRealTarget = Get_FormulaRange_Unit(strFormula, sht)
If rngRealTarget Is Nothing Then
' 참조 영역 주소 반환 오류
Set_Auto_Expand_Format_Formula = False
Exit Function
End If
' -----------------------------------------------
' 수식 복사를 위한 기초 범위 계산 끝
' -----------------------------------------------
If rngRealTarget.Parent.Name <> sht.Name Then
' 작업 대상 워크시트가 서로 다름
' 백업시트에서 수식 복구
For Each rngLoop In rngRealTarget.Areas
rngLoop.Copy Destination:=sht.Range(rngLoop.Address)
Next rngLoop
Else
' -----------------------------------------------
' 수식 복사
' -----------------------------------------------
For Each rngLoop In rngRealTarget.Areas
If IsEmpty(rng.Offset(, 2).Value) Then
' 행의 건수가 지정되지 않았음
' 처리 안함
Else
' 적용할 수식/포맷 정의 범위 계산
Set rngSource = Application.Intersect(rng.EntireRow, rngLoop.EntireColumn)
' 적용될 범위 계산
strFormula = Mid(rng.Offset(, 1).Formula, 2)
Set rngApplyTarget = Get_FormulaRange_Unit(strFormula, sht)
' 너비와 행높이 계산
iRowCount = Application.WorksheetFunction.Max(1, rng.Offset(, 2).Value)
iColumnWidth = rngLoop.Columns.Count
iRowHeight = rngLoop.Rows.Count * iRowCount
' 적용할 원본 범위를 복사
rngLoop.Copy
' 대상 범위를 순환하면서 수식과 서식을 적용
For Each rngLoopTarget In rngApplyTarget
rngLoopTarget.Resize(iRowHeight, iColumnWidth).PasteSpecial Paste:=xlPasteFormulas, SkipBlanks:=SkipBlank
rngLoopTarget.Resize(iRowHeight, iColumnWidth).PasteSpecial Paste:=xlPasteFormats
Next rngLoopTarget
End If
Next rngLoop
' -----------------------------------------------
' 수식 복사 끝
' -----------------------------------------------
' -----------------------------------------------
' 숨김처리 지정 범위 처리
' -----------------------------------------------
If IsEmpty(rng.Offset(, 3).Value) Then
' 초기화할 범위 지정내용이 없음
Else
' 범위가 지정됨
' 행 숨김처리 실행
strFormula = Mid(rng.Offset(, 3).Formula, 2)
Set rngRealTarget = Get_FormulaRange_Unit(strFormula, sht)
If rngRealTarget Is Nothing Then
' 범위가 지정되었으나 실제 범위 지정에 오류가 있음
' 처리 불가
Else
' 숨김처리 실행
For Each rngLoop In rngRealTarget
Call Hide_Row(rngLoop)
Next rngLoop
End If
End If
' -----------------------------------------------
' 숨김처리 지정 범위 처리 끝
' -----------------------------------------------
End If
End If
Next rng
Set_Auto_Expand_Format_Formula = True
End Function
모듈명 : m_Set_Init
Option Explicit
Option Compare Text
'
' 출력된 범위의 BasePoint 를 기준으로 데이터 초기화
'
Public Sub Clear_BasePoint(Optional sht As Worksheet)
' Dim shtView As Worksheet
'
' If sht Is Nothing Then
' For Each sht In ActiveWorkbook.Worksheets
' Set shtView = sht
' Call Clear_Auto_Expand(shtView)
' Next sht
' Else
' Set shtView = sht
' Call Clear_BasePoint_Exec(shtView)
' Call Clear_BasePoint_Exec(shtView)
' End If
End Sub
Sub test_Clear_Auto_Expand()
Call Clear_Auto_Expand
End Sub
'
' 자동확장 범위의 데이터 초기화 - 호출
'
Public Sub Clear_Auto_Expand(Optional sht As Worksheet)
Dim shtView As Worksheet
If sht Is Nothing Then
For Each sht In ActiveWorkbook.Worksheets
Set shtView = sht
Call Init_Auto_Expand_Main(shtView)
Next sht
Else
Set shtView = sht
Call Init_Auto_Expand_Main(shtView)
End If
End Sub
'
' 출력된 범위의 BasePoint 를 기준으로 데이터 초기화 - 실행
'
Public Sub Clear_BasePoint_Exec(shtView As Worksheet)
' Dim rng As Range
'
' ' 뷰 시트인지 검사
' If IsView(shtView) Then
' Else
' ' 뷰 시트가 아님
' ' 종료
' Exit Sub
' End If
'
' Set rng = Get_NamedRange("_Def_Auto_Expand_Col_", shtView)
'
' If rng Is Nothing Then
' Else
' Call Init_Auto_Expand(rng)
' End If
End Sub
'
' 자동확장 범위의 데이터 초기화 - 메인
'
Public Sub Init_Auto_Expand_Main(shtView As Worksheet)
Dim rng As Range
' 뷰 시트인지 검사
If IsView(shtView) Then
Else
' 뷰 시트가 아님
' 종료
Exit Sub
End If
Set rng = Get_NamedRange("_Def_Auto_Expand_Col_", shtView)
If rng Is Nothing Then
Else
Call Init_Auto_Expand_Exec(rng, shtView)
End If
End Sub
'
' 자동확장 범위의 데이터 초기화 - 실행
'
Public Sub Init_Auto_Expand_Exec(rngDefineColumn As Range, shtView As Worksheet)
Dim rng As Range
Dim rngInit As Range
Dim i As Integer
Dim arrRange As Variant
' -----------------------------------------------
' 초기화 지정 범위 초기화 실행
' -----------------------------------------------
For Each rng In rngDefineColumn
If IsEmpty(rng.Offset(, -1).Value) Then
' 초기화할 범위 지정내용이 없음
Else
' 범위가 지정됨
' Clear 실행
' Stop
arrRange = Split(rng.Offset(, -1).Formula & ",", ",")
For i = 0 To UBound(arrRange)
If UCase(CStr(arrRange(i))) = "AUTO" Then
Set rngInit = Get_AutoExpandRange(shtView, rng)
ElseIf Len(CStr(arrRange(i))) > 0 Then
Set rngInit = Get_String2Range(shtView, CStr(arrRange(i)))
End If
If rngInit Is Nothing Then
' 범위가 지정되었으나 실제 범위 지정에 오류가 있음
' 처리 불가
Else
' Clear : 서식, 수식 모두 삭제
rngInit.Clear
Set rngInit = Nothing
End If
Next i
End If
Next rng
' -----------------------------------------------
' 초기화 지정 범위 초기화 실행 끝
' -----------------------------------------------
End Sub
'
' 조회 조건 동기화
'
Public Sub Set_User_Condition_Sync()
Dim nmCBO_UserCondition As Name
Dim nmVS_Condition As Name
On Error Resume Next
'Application.Calculation = xlCalculationManual
' 데이터 조회 Flag Setting
ActiveWorkbook.Names("VS_PRE_CLEAR_DATA").RefersToRange.Value = 1
For Each nmCBO_UserCondition In ActiveWorkbook.Names
If nmCBO_UserCondition.Name Like "VS_CBO_*" Then
Set nmVS_Condition = ActiveWorkbook.Names(Application.WorksheetFunction.Substitute(nmCBO_UserCondition.Name, "_CBO", ""))
nmVS_Condition.RefersToRange.Value = nmCBO_UserCondition.RefersToRange.Value
Err.Clear
End If
Next nmCBO_UserCondition
'Application.Calculation = xlCalculationAutomatic
End Sub
'
' 기본 뷰 시트 초기 셋팅
'
Public Sub Set_InitView(Optional sht As Worksheet, Optional SkipBlank As Boolean = True)
' ======================================================================
' 변수명 설명
' ----------------------------------------------------------------------
'
' sht 작업대상 워크시트, 지정하지 않으면 모든 시트
' SkipBlank 수식을 복사할 때 빈 셀은 제외할 것인지 설정, 기본값은 True 이고 빈 셀은 제외함
'
' ======================================================================
Dim shtActive As Worksheet
' 현재 활성 시트 백업
Set shtActive = ActiveSheet
' 스타일 병합
Call Style_Merge
'
' 조회 되었음 Flag 설정
'
With ActiveWorkbook
.Names("VS_DATA_REFRESHED").RefersToRange.Value = True
End With
If sht Is Nothing Then
' 대상 시트가 지정되지 않음
' 대상 시트들을 모두 처리
For Each sht In ActiveWorkbook.Worksheets
Call Set_Init(sht, SkipBlank)
Next sht
Else
' 대상 시트가 지정되지 않음
' 넘겨 받은 시트를 대상으로 작업
'Set sht = ActiveSheet
Call Set_Init(sht, SkipBlank)
End If
' 초기 활성 시트 활성화
shtActive.Activate
End Sub
' 기본 수식, 서식, 실적구간 스타일, 입력구간 스타일 적용
Public Sub Set_Init(sht As Worksheet, SkipBlank As Boolean)
' ======================================================================
' 변수명 설명
' ----------------------------------------------------------------------
'
' TargetSheetList 작업대상 워크시트 이름 리스트, 콤마로 구분
' SkipBlank 수식을 복사할 때 빈 셀은 제외할 것인지 설정, 기본값은 True 이고 빈 셀은 제외함
'
' ======================================================================
Dim arrTargetSheet As Variant
Dim rngDefineColumn As Range
Dim rngDefineRow As Range
Dim strStyleName As String
Dim bSuccess As Boolean
Dim bVer_Status As Boolean
Dim bExistAutoExpand As Boolean
Dim resp As VbMsgBoxResult
' 뷰 시트인지 검사
If IsView(sht) Then
Else
' 뷰 시트가 아님
' 종료
Exit Sub
End If
'
' Scroll Area 제거
'
sht.ScrollArea = ""
' ---------------------------------------------------
' 입력/저장 구간에 대한 기본 스타일 적용
Call Set_Input_Style("DEFAULT", sht)
' ---------------------------------------------------
' ---------------------------------------------------
' 기본 수식 및 서식 복사
bSuccess = Set_Default_Format_Formula(sht, SkipBlank)
If bSuccess Then
Else
Call ShowMessage(strPrompt:="기본 수식을 적용할 참조 범위에 오류가 있습니다.", Button:=vbCritical, strTitle:="범위 오류")
'MsgBox "기본 수식을 적용할 참조 범위에 오류가 있습니다.", vbCritical, "범위 오류"
Exit Sub
End If
'
' 버전 마감 여부
'
bVer_Status = Get_Version_Status
' ---------------------------------------------------
' 자동 범위 확장 수식 및 서식 복사
bSuccess = Set_Auto_Expand_Format_Formula(sht, SkipBlank, bExistAutoExpand, bVer_Status)
If bSuccess Then
Else
If bExistAutoExpand Then
' 자동확장 이름 정의가 없음
' Skip
Else
Call ShowMessage(strPrompt:="자동 범위 확장 수식을 적용할 참조 범위에 오류가 있습니다.", Button:=vbCritical, strTitle:="범위 오류")
'MsgBox "자동 범위 확장 수식을 적용할 참조 범위에 오류가 있습니다.", vbCritical, "범위 오류"
Exit Sub
End If
End If
' ---------------------------------------------------
' ---------------------------------------------------
' 입력 구간 스타일 적용
' 입력 대상 정의 기본 범위 설정
If bVer_Status Then
If bExistAutoExpand Then
Else
' 마감된 버전이 아니면 입력 구간 스타일 설정
Call Set_Input_Style("INPUT", sht)
End If
' 계산영역이고 저장되는 범위 스타일 설정
Set rngDefineColumn = Get_NamedRange("_Def_Calc_Save_Col_", sht)
Set rngDefineRow = Nothing
strStyleName = "CALC_SAVE"
' 스타일 적용 실행
Call Set_Style(sht, rngDefineColumn, rngDefineRow, strStyleName)
End If
' ---------------------------------------------------
' 실적 구간 스타일 적용
' 실적 대상 정의 기본 범위 설정
Set rngDefineColumn = Get_NamedRange("_Def_Actual_Col_", sht)
Set rngDefineRow = Get_NamedRange("_Def_Actual_Row_", sht)
'strStyleName = "TOP_HEADER_ACTUAL"
' 스타일 적용 실행 - 실적/계획 구간 타이틀
Call Set_Style_AP(sht, rngDefineColumn)
' 불필요한 열 숨김 처리
Call Hide_Columns(sht)
' 불필요한 행 숨김 처리
Call Hide_Rows(sht)
' 초기 위치로 이동
Application.Goto Reference:=sht.Range("A1"), Scroll:=True
End Sub
'
' 입력 구간 스타일 설정
'
Public Sub Set_Input_Style(strStyleName As String, sht As Worksheet)
Dim rngDefineColumn As Range
Dim rngDefineRow As Range
' 마감된 버전이 아니면 입력 구간 스타일 설정
Set rngDefineColumn = Get_NamedRange("_Def_Input_Col_", sht)
Set rngDefineRow = Get_NamedRange("_Def_Input_Row_", sht)
' 스타일 적용 실행
Call Set_Style(sht, rngDefineColumn, rngDefineRow, strStyleName)
End Sub
'
' 스타일 적용
'
Public Sub Set_Style_Apply___(rngBase As Range, rngTitle As Range, strStyleName As String)
Dim rngTarget As Range
Dim rngWhat As Range
Dim rngApplyStyle As Range
' 스타일 적용을 위한 기본 범위 계산
Set rngWhat = Get_ResizeBaseRange(rngBase)
If rngWhat Is Nothing Then
'Set_Style_Apply = False
' 대상 범위 없음
Exit Sub
End If
' 대상 열 범위 계산
Set rngTarget = Get_SpecialCells(rngTitle, xlCellTypeFormulas, xlTextValues)
If rngTarget Is Nothing Then
'Set_Style_Apply = False
' 대상 범위 없음
Exit Sub
End If
' 스타일 적용 대상 범위 계산
Set rngApplyStyle = Application.Intersect(rngWhat.EntireRow, rngTarget.EntireColumn)
' 색상 적용:스타일 정의
rngApplyStyle.Style = strStyleName
'Set_Style_Apply = True
End Sub
'
' Edge 테두리 그리기
'
Public Sub Draw_Border(rng As Range, BorderWeight As XlBorderWeight)
Dim rngBorder As Range
Dim rngTarget As Range
Set rngBorder = Worksheets(rng.Parent.Name).Names("_BORDER_").RefersToRange
Set rngTarget = Application.Intersect(rngBorder.EntireColumn, rng)
' ----------------------------------------------------
' Edge 테두리 그리기
' 위쪽 선 그리기
Call Set_Border(rngTarget, xlEdgeTop, BorderWeight)
' 아래쪽 선 그리기
Call Set_Border(rngTarget, xlEdgeBottom, BorderWeight)
' 왼쪽 선 그리기
Call Set_Border(rngTarget, xlEdgeLeft, BorderWeight)
' 오른쪽 선 그리기
Call Set_Border(rngTarget, xlEdgeRight, BorderWeight)
' ----------------------------------------------------
End Sub
'
' 선그리기
'
Public Sub Set_Border(rng As Range, EdgePosition As XlBordersIndex, BorderWeight As XlBorderWeight)
With rng.Borders(EdgePosition)
.LineStyle = xlContinuous
.ThemeColor = 2
.TintAndShade = 0.499984740745262
.Weight = BorderWeight
End With
End Sub
모듈명 : m_Style
Option Explicit
'
' 스타일 병합
'
Public Sub Style_Merge()
On Error Resume Next
Application.DisplayAlerts = False
ActiveWorkbook.Styles.Merge Workbook:=ThisWorkbook
Application.DisplayAlerts = True
End Sub
'
' 스타일 적용
'
Public Sub Set_Style(sht As Worksheet, rngDefineColumn As Range, rngDefineRow As Range, strStyleName As String)
' ======================================================================
' 변수명 설명
' ----------------------------------------------------------------------
'
' sht 작업대상 워크시트
' rngDefineColumn 작업대상 정의 범위(열)
' rngDefineRow 작업대상 정의 범위(행)
' strStyleName 적용할 스타일 이름
'
' ======================================================================
Dim rngRealTarget As Range
Dim rngTarget As Range
Dim rng As Range
Dim rngLoop As Range
Dim rngStyle As Range
Dim rngApply As Range
If rngDefineColumn Is Nothing Then
' 계산 영역이면서 저장되어야 하는 영역 정의가 안된 화면이 있을 수 있음
' 나중에 추가된 이유로 인하여 예외처리로 추가
' 해당 보고서에 이름 정의를 추가하여 처리가 필요함
' 필요한 이름 정의
'
' 이름 : _Def_Calc_Save_Col_
' 범위 : 대상시트명!$AJ$28:$AJ$32 --> 기본 이름정의 영역임
' ex) ='V1'!$AJ$28:$AJ$32
'
Exit Sub
End If
For Each rng In rngDefineColumn
If IsEmpty(rng.Value) Then
' 빈 셀 검사
Else
' 실제 대상 범위
Set rngRealTarget = Get_FormulaRange_Unit(Mid(rng.Formula, 2), sht)
If rngRealTarget.Parent.Name <> sht.Name Then
' 작업 대상 워크시트가 서로 다름
' 작업 불가
Else
For Each rngLoop In rngRealTarget.Areas
' 스타일 적용을 위한 기본 정의 영역 계산
Set rngStyle = Application.Intersect(rng.EntireRow, rngLoop.EntireColumn)
' 문자열이 들어있는 셀 추출
Set rngTarget = Get_SpecialCells(rngTarget:=rngStyle, CellType:=xlCellTypeConstants + xlCellTypeFormulas, CellValue:=xlTextValues)
If rngTarget Is Nothing Then
' 적용할 대상 범위가 없음
Else
' 적용할 대상 범위 계산
Set rngApply = Application.Intersect(rngLoop.EntireRow, rngTarget.EntireColumn)
' 지정한 스타일 적용
rngApply.Style = strStyleName
End If
Next rngLoop
End If
End If
Next rng
End Sub
'
' 스타일 적용(실적/계획 타이틀)
'
Public Sub Set_Style_AP(sht As Worksheet, rngDefineColumn As Range)
' ======================================================================
' 변수명 설명
' ----------------------------------------------------------------------
'
' sht 작업대상 워크시트
' rngDefineColumn 작업대상 정의 범위(열)
' rngDefineRow 작업대상 정의 범위(행)
'
' ======================================================================
Dim rngRealTarget As Range
Dim rngTarget As Range
Dim rng As Range
Dim rngLoop As Range
Dim rngStyle As Range
Dim rngApply As Range
Dim rngActual As Range
Dim rngPlan As Range
Dim rtn As Boolean
For Each rng In rngDefineColumn
If IsEmpty(rng.Value) Then
' 빈 셀 검사
Else
' 실제 대상 범위
Set rngRealTarget = Get_FormulaRange_Unit(Mid(rng.Formula, 2), sht)
If rngRealTarget.Parent.Name <> sht.Name Then
' 작업 대상 워크시트가 서로 다름
' 작업 불가
Else
For Each rngLoop In rngRealTarget.Areas
' 스타일 적용을 위한 기본 정의 영역 계산
Set rngStyle = Application.Intersect(rng.EntireRow, rngLoop.EntireColumn)
' 문자열이 들어있는 셀 추출
Set rngTarget = Get_SpecialCells(rngTarget:=rngStyle, CellType:=xlCellTypeConstants + xlCellTypeFormulas, CellValue:=xlTextValues)
If rngTarget Is Nothing Then
' 적용할 대상 범위가 없음
Else
rtn = Get_Actual_Plan_Term(rngTarget, rngActual, rngPlan)
If rngActual Is Nothing Then
Else
Set rngTarget = Application.Intersect(rngActual.EntireColumn, rngRealTarget)
rngTarget.Style = "TOP_HEADER_ACTUAL"
End If
If rngPlan Is Nothing Then
Else
Set rngTarget = Application.Intersect(rngPlan.EntireColumn, rngRealTarget)
rngTarget.Style = "TOP_HEADER_PLAN"
End If
End If
Next rngLoop
Set rngTarget = Get_SpecialCells(rngTarget:=rngApply, CellType:=xlCellTypeConstants + xlCellTypeFormulas, CellValue:=xlTextValues)
End If
End If
Next rng
End Sub
'
' 실적, 계획 구간 범위 계산
'
Public Function Get_Actual_Plan_Term(rngTarget As Range, rngActual As Range, rngPlan As Range) As Boolean
Dim rng As Range
Dim rngP As Range
Dim rngA As Range
On Error GoTo ErrTrap
For Each rng In rngTarget
If IsError(rng.Value) Then
Else
Select Case UCase(rng.Value)
Case "P", "계획"
Set rngP = Union_Range(rngP, rng)
Case "A", "실적"
Set rngA = Union_Range(rngA, rng)
End Select
End If
Next rng
Set rngActual = rngA
Set rngPlan = rngP
Get_Actual_Plan_Term = True
Exit Function
ErrTrap:
Set rngActual = Nothing
Set rngPlan = Nothing
Get_Actual_Plan_Term = False
End Function
'
' 스타일 적용
'
Public Sub Set_Style_ORG(sht As Worksheet, rngDefineColumn As Range, rngDefineRow As Range, strStyleName As String)
' ======================================================================
' 변수명 설명
' ----------------------------------------------------------------------
'
' sht 작업대상 워크시트
' rngDefineColumn 작업대상 정의 범위(열)
' rngDefineRow 작업대상 정의 범위(행)
' strStyleName 적용할 스타일 이름
'
' ======================================================================
Dim rngRealTarget As Range
Dim rngTarget As Range
Dim rng As Range
Dim rngLoop As Range
Dim rngStyle As Range
Dim rngApply As Range
' 스타일 병합
Call Style_Merge
For Each rng In rngDefineColumn
If IsEmpty(rng.Value) Then
' 빈 셀 검사
Else
' 실제 대상 범위
Set rngRealTarget = Get_FormulaRange_Unit(Mid(rng.Formula, 2), sht)
If rngRealTarget.Parent.Name <> sht.Name Then
' 작업 대상 워크시트가 서로 다름
' 작업 불가
Else
For Each rngLoop In rngRealTarget.Areas
' 스타일 적용을 위한 기본 정의 영역 계산
Set rngStyle = Application.Intersect(rng.EntireRow, rngLoop.EntireColumn)
' 문자열이 들어있는 셀 추출
Set rngTarget = Get_SpecialCells(rngTarget:=rngStyle, CellType:=xlCellTypeConstants + xlCellTypeFormulas, CellValue:=xlTextValues)
If rngTarget Is Nothing Then
' 적용할 대상 범위가 없음
Else
' 적용할 대상 범위 계산
Set rngApply = Application.Intersect(rngLoop.EntireRow, rngTarget.EntireColumn)
' 지정한 스타일 적용
rngApply.Style = strStyleName
End If
Next rngLoop
End If
End If
Next rng
End Sub
모듈명 : m_Vars
Option Explicit
Public Const cstrMsgTitle As String = "경영계획" ' Message Title
Public Const cstrMsgTitleSave As String = "저장"
Public Enum FirstKey_Direction
Column = 1
Row = 2
End Enum
Public Enum User_Auth
Auth_Save = 1
Auth_ReqApproval = 2
Auth_Approval = 4
End Enum
Public Enum CRUDExecuteType
MergeInsert = 1 ' MERGE INTO
DeleteInsert = 2 ' DELETE / INSERT
Insert = 4 ' INSERT
TruncateInsert = 8 ' TRUNCATE / INSERT
ByRow = 16 ' 행 단위로 구분자 지정(U:Update D:Delete C:Insert)
UseSheetSetting = 32 ' 시트에 설정된 그대로 실행
End Enum
'
'
'' Column 정보
'Public Const cstrInputRowAddr As String = "B101:F101" ' 입력 대상 행
'
'
'Public Const cstrLogNodeIdxAddr As String = "L101" ' PIVOT CODE INDEX
'Public Const cstrCurrencyYNAddr As String = "M101" ' 환율 여부
'Public Const cstrLogicNodeAddr As String = "N101" ' Node Code
'Public Const cstrFormulaYearAddr As String = "O101" ' 연도에 적용할 수식 정보
'Public Const cstrFormulaActAddr As String = "P101" ' 실적에 적용할 수식 정보
'Public Const cstrFormulaPlanAddr As String = "Q101" ' 계획에 적용할 수식 정보
'Public Const cstrAccuTypeAddr As String = "S100" ' Accumulate Type 정보 저장
'Public Const cstrDisplayFormatAddr As String = "U101" ' 표시형식
'Public Const cstrGenerationAddr As String = "V101" ' Node 의 Level 정보
'Public Const cstrHideRowAddr As String = "W101" ' 행 무조건 숨김처리
'Public Const cstrCalcRowAddr As String = "X101" ' 트리구조 임시 계산 열
'Public Const cstrTreeHideRowAddr As String = "Y101" ' 트리구조 숨기기/보이기 정보 저장 열
'Public Const cstrBaseAddr As String = "AA100" ' 타이틀
'Public Const cstrDataAddr As String = "AA101" ' 데이터 시작
'
'Public Const cstrLeafNodeAddr As String = "D101" ' Leaf Node 여부 : 1 = Leaf, 0 = Brach
'Public Const cstrRevFormulaAddr As String = "E101" ' 역산 수식
'Public Const cstrRevFormulaAddr2 As String = "F101" ' 역산 수식2
'Public Const cstrSalesYNAddr As String = "G101" ' 매출 대상 여부
'Public Const cstrAccuAddr As String = "AS101" ' 비교버전/작성버전/차이
'
'
'' Row 정보
'Public Const cstrInputColAddr As String = "BA3:BA7" ' 입력 대상 열
'
'
'Public Const cstrCalcColAddr As String = "AA3" ' 임시 계산 행
'Public Const cstrDataTypeAddr As String = "AA5" ' 데이터성격
'Public Const cstrAccuCalcAddr As String = "AA9" ' 누계계산 대상 열
'Public Const cstrBorderAddr As String = "AA11" ' 테두리 작업 대상 행
'Public Const cstrColHideAddr As String = "AA13" ' 열 숨김 처리
'Public Const cstrFormulaTypeAddr As String = "AP86" ' 적용할 수식 유형 범위
'
'Public Const cSTRC_Size As Integer = 14
'Public Const cBaseRow As Integer = 100
'
'Public Const cColumnSize As Integer = 120 ' 최대 작업대상 열 너비
'Public Const cRowSize As Integer = 10000 ' 최대 작업대상 행 높이
'
'Public Const DebugMode As Boolean = False
'
모듈명 : Tools
Option Explicit
'
Public Sub close_me()
ThisWorkbook.Close savechanges:=False
End Sub
Public Sub Replace_P1()
Dim wbTemplate As Workbook
Dim wbTarget As Workbook
Dim shtTemplateP1 As Worksheet
Dim shtTargetP1 As Worksheet
Dim rngDefaultP1 As Range
Dim rngTargetP1 As Range
Set wbTemplate = Workbooks("")
Set wbTarget = ActiveWorkbook
Set shtTemplateP1 = wbTemplate.Worksheets("P1")
Set shtTargetP1 = wbTarget.Worksheets("P1")
Set rngDefaultP1 = shtTemplateP1.Range("B1").Resize(, 4).EntireColumn
Set rngTargetP1 = shtTargetP1.Range("B1").Resize(, 4).EntireColumn
rngDefaultP1.Copy Destination:=rngTargetP1
rngTargetP1.Replace What:="[]", Replacement:=""
End Sub
Public Sub Clear_Style()
' 스타일CLEAR
Dim stl_style As Style
On Error Resume Next
For Each stl_style In ActiveWorkbook.Styles
Select Case UCase(stl_style.Name)
Case "AGGREGATION", "CALCULATE", _
"COMMA0", "COMMA1", "COMMA2", "COMMA3", "COMMA4", _
"INPUT", "LEFT_HEADER", _
"NUM0", "NUM1", "NUM2", "NUM3", "NUM4", _
"PCT0", "PCT1", "PCT2", "PCT3", "PCT4", _
"SUB_TOTAL", "TOTAL", "NORMAL", _
"TOP_HEADER", "TOP_HEADER_ACTUAL", "TOP_HEADER_PLAN", _
"BUTTON", "LABEL_STATUS", "LABEL", "DEFAULT", _
"BORDER_ALL", "BORDER_ALL_T", "DATE" ' , "DATA"
Case Else
stl_style.Delete
End Select
' If stl_style.Name Like "BORDER_*" Then
' End If
'stl_style.Delete
' If stl_style.Name Like "부*" Then
' stl_style.Delete
' ElseIf stl_style.Name Like "선*" Then
' stl_style.Delete
' ElseIf stl_style.Name Like "스*" Then
' stl_style.Delete
' ElseIf stl_style.Name Like "총*" Then
' stl_style.Delete
' ElseIf stl_style.Name Like "표*" Then
' stl_style.Delete
' ElseIf stl_style.Name Like "M*" Then
' stl_style.Delete
' End If
'' debug.print ActiveWorkbook.Styles.Count
Next stl_style
End Sub
Public Sub abcde()
' 이름 보이기
Dim n As Name
For Each n In Names
n.Visible = True
Next n
End Sub
Public Sub color_list()
Dim i As Integer
On Error Resume Next
For i = 0 To 100
Cells(i, 1).Interior.ColorIndex = i
Next i
End Sub
Sub aaaa()
Dim aaa As XlSpecialCellsValue
Dim r As Boolean
aaa = xlErrors + xlLogical + xlTextValues + xlNumbers + xlErrors
r = aaa And XlSpecialCellsValue.xlErrors: '' debug.print r
r = aaa And XlSpecialCellsValue.xlLogical: '' debug.print r
r = aaa And XlSpecialCellsValue.xlNumbers: '' debug.print r
r = aaa And XlSpecialCellsValue.xlTextValues: '' debug.print r
End Sub
Sub sssssssssssssss()
Dim s As Worksheet
For Each s In Worksheets
s.Visible = xlSheetVisible
Next
End Sub
Sub Macro1()
Dim rng As Range
Dim s As Style
On Error Resume Next
For Each rng In Selection
If IsEmpty(rng.Value) Then
Else
'ThisWorkbook.Styles(rng.Value).Delete
Set s = ActiveWorkbook.Styles.Add(Name:=rng.Value, BasedOn:=rng.Offset(, 2))
rng.Offset(, 2).Style = rng.Value
End If
Next rng
For Each s In ThisWorkbook.Styles
If s.Name Like "BORDER*" Then
With s
.IncludeNumber = False
.IncludeFont = False
.IncludeAlignment = False
.IncludeBorder = True
.IncludePatterns = False
.IncludeProtection = False
End With
ElseIf rng.Offset(, 2).Value > 0 Then
If s.Name Like "*_*" Then
With s
.IncludeNumber = True
.IncludeFont = False
.IncludeAlignment = False
.IncludeBorder = False
.IncludePatterns = True
.IncludeProtection = False
End With
Else
With s
.IncludeNumber = True
.IncludeFont = False
.IncludeAlignment = False
.IncludeBorder = False
.IncludePatterns = False
.IncludeProtection = False
End With
End If
Else
Select Case s.Name
Case "TOP_HEADER", "LEFT_HEADER", "Total", "SUB_TOTAL", "INPUT", "CALC", "Data"
With s
.IncludeNumber = False
.IncludeFont = False
.IncludeAlignment = False
.IncludeBorder = False
.IncludePatterns = True
.IncludeProtection = False
End With
End Select
End If
Next s
End Sub
Sub ADFDSAAGDFHGSHYERTJHS()
Dim rng As Range
Set rng = Range(Mid(ActiveCell.Formula, 2))
' debug.Print rng.Parent.Name, rng.Address
' debug.Print ActiveCell.Formula
End Sub
''--------------------------------------------------------------------------------'
' 'Conn.crud Target Sheet, Execute Type, [Data Range] '
' 'Sheet : CRUD Sheet (표준양식 반드시 준수) '
' 'Execute Type : "T" - TRUNCATE / INSERT '
' ' "D" - DELETE / INSERT '
' ' "M" - MERGE INTO '
' ' "N" - INSERT '
' ' "R" - 행 단위로 구분자 지정(U:Update D:Delete C:Insert) '
' '[Data Range]: Execute Range / 미지정 시 전체 데이터 실행 '
' 'Me = 해당 시트 (모듈에서 사용할 경우 시트를 명확히 재지정) '
''--------------------------------------------------------------------------------'
Public Function MTX_CRUD(sht As Worksheet, strMsg As String) As Boolean
Dim lngEnd As Long
'Dim rPoint As Range
Dim rData As Range
Dim strExecute As String
Dim addin As COMAddIn
Dim mxmodule As Object
Dim bSuccess As Boolean
Dim WorkResultMessage As String
Dim rngData As Range
Dim rngClear As Range
' 기존 데이터 Clear
Set rData = sht.Range("C_Caption")
Set rngData = Get_ResizeBaseRange(rData)
If rngData Is Nothing Then
Else
Set rngClear = Application.Intersect(rData.CurrentRegion, rngData.EntireRow)
If rngClear Is Nothing Then
Else
rngClear.ClearContents
End If
End If
' 데이터 생성 호출
bSuccess = Make_Data4Save(sht, WorkResultMessage)
If bSuccess Then
' 데이터 생성 성공
MTX_CRUD = True
Else
' 데이터 생성 실패
MTX_CRUD = False
strMsg = WorkResultMessage
Call ShowMessage(strPrompt:=strMsg, Button:=vbCritical + vbOKOnly, strTitle:="저장 오류")
'MsgBox WorkResultMessage, vbCritical + vbOKOnly, "저장 오류"
Exit Function
End If
On Error GoTo hErr
Set addin = Application.COMAddIns.Item("ExcelModule.AddinModule")
Set mxmodule = addin.Object
'Set rPoint = rData.Offset(1)
'Set rPoint = sht.Range("C_BasePoint")
Set rngData = Get_ResizeBaseRange(rData)
' lngEnd = sht.Range("D" & Rows.Count).End(xlUp).Row
strExecute = sht.Range("c_Execute").Value
If rngData Is Nothing Then
' If lngEnd = rPoint.Row - 1 Then '''데이터 유무 판다후 진행
strMsg = "입력된 데이터가 없습니다."
Call ShowMessage(strPrompt:=strMsg, Button:=vbInformation, strTitle:=cstrMsgTitleSave)
'MsgBox strMsg, vbInformation, cstrMsgTitleSave
Else
If strExecute = "R" And Application.WorksheetFunction.CountA(rngData.Offset(, -1)) = 0 Then
strMsg = "C열에 구분자를 입력(U:Update, D:Delete, C:Insert) 하십시요."
Call ShowMessage(strPrompt:=strMsg, Button:=vbInformation, strTitle:=cstrMsgTitleSave)
'MsgBox strMsg, vbInformation, cstrMsgTitleSave
Else
mxmodule.xapi.crud sht, strExecute
If mxmodule.xapi.LastErrorCode <> 0 Then
If mxmodule.xapi.LastErrorMessage = "Unknown error" Then
strMsg = "DB접속 정보가 없습니다."
'MsgBox strMsg, vbCritical, cstrMsgTitleSave
Else
strMsg = mxmodule.xapi.LastErrorMessage
'MsgBox mxmodule.xapi.LastErrorMessage, vbCritical, cstrMsgTitleSave
End If
Call ShowMessage(strPrompt:=strMsg, Button:=vbCritical, strTitle:=cstrMsgTitleSave)
Else
strMsg = "저장 되었습니다." & vbCrLf & "Info" & mxmodule.xapi.ResponseData
Call ShowMessage(strPrompt:=strMsg, Button:=vbInformation, strTitle:=cstrMsgTitleSave)
'MsgBox strMsg, vbInformation, cstrMsgTitleSave '''저장 되었으면
'Set rData = rPoint.CurrentRegion.Offset(rPoint.Row - 2) '''데이터 삭제
'rData.Clear
End If
End If
End If
hErr:
If Err <> 0 Then
strMsg = Err.Description
Call ShowMessage(strPrompt:=strMsg, Button:=vbExclamation, strTitle:=cstrMsgTitleSave)
' MsgBox Err.Description
End If
MTX_CRUD = (Err = 0)
Set addin = Nothing
Set mxmodule = Nothing
End Function
Sub ddadfagafdgfda()
Range("b4").CurrentRegion.Copy
Range("e4").PasteSpecial Paste:=xlPasteValues
End Sub