엑셀 재고관리 프로그램 만들기 - VBA 매크로 필수 기능 총정리

'<-- 21.08.19 수정 : DB 비어있을 시, 오류 대신 비어있는 DB 반환 -->
If IsEmpty(DB) Then Filtered_DB = DB: Exit Function

Option Explicit
Option Compare Text
'########################
' 특정 워크시트에서 앞으로 추가해야 할 최대 ID번호 리턴 (시트 DB 우측 첫번째 머릿글)
' i = Get_MaxID(Sheet1)
'########################
Function Get_MaxID(WS As Worksheet) As Long
With WS
    Get_MaxID = .Cells(1, .Columns.Count).End(xlToLeft).Value
    .Cells(1, .Columns.Count).End(xlToLeft).Value = .Cells(1, .Columns.Count).End(xlToLeft).Value + 1
End With
End Function
'########################
' 워크시트에 새로운 데이터를 추가해야 할 열번호 반환
' i = Get_InsertRow(Sheet1)
'########################
Function Get_InsertRow(WS As Worksheet) As Long
With WS:    Get_InsertRow = .Cells(.Rows.Count, 1).End(xlUp).Row + 1: End With
End Function
'########################
' 시트의 열 개수 반환 (이번 예제파일에서만 사용)
' i  = Get_ColumnCnt(Sheet1)
'########################
Function Get_ColumnCnt(WS As Worksheet, Optional Offset As Long = -1) As Long
With WS:    Get_ColumnCnt = .Cells(1, .Columns.Count).End(xlToLeft).Column + Offset: End With
End Function
'########################
' 시트에서 특정 ID 의 행 번호 반환 (-> 해당 행 번호 데이터 업데이트)
' i = get_UpdateRow(Sheet1, ID)
'########################
Function get_UpdateRow(WS As Worksheet, ID)
Dim i As Long
Dim cRow As Long
With WS
    cRow = Get_InsertRow(WS) - 1
    For i = 1 To cRow
        If .Cells(i, 1).Value = ID Then get_UpdateRow = i: Exit For
    Next
End With
End Function
 
 
'########################
' 특정 시트의 DB 정보를 배열로 반환 (이번 예제파일에서만 사용)
' Array = Get_DB(Sheet1)
'########################
Function Get_DB(WS As Worksheet, Optional NoID As Boolean = False, Optional IncludeHeader As Boolean = False) As Variant
 
Dim cRow As Long
Dim cCol As Long
Dim offCol As Long
 
If NoID = False Then offCol = -1
 
With WS
    cRow = Get_InsertRow(WS) - 1
    cCol = Get_ColumnCnt(WS, offCol)
    Get_DB = .Range(.Cells(2 + Sgn(IncludeHeader), 1), .Cells(cRow, cCol))
End With
 
End Function
'########################
'특정 시트에서 지정한 ID의 필드 값 반환 (이번 예제파일 전용)
' Value = Get_Records(Sheet1, ID, "필드명")
'########################
Function Get_Records(WS As Worksheet, ID, Fields)
 
Dim cRow As Long: Dim cCol As Long
Dim vFields As Variant: Dim vField As Variant
Dim vFieldNo As Variant
Dim i As Long: Dim j As Long
 
 
cRow = Get_InsertRow(WS) - 1
cCol = Get_ColumnCnt(WS)
 
If InStr(1, Fields, ",") > 0 Then vFields = Split(Fields, ",") Else vFields = Array(Fields)
ReDim vFieldNo(0 To UBound(vFields))
 
With WS
    For Each vField In vFields
        For i = 1 To cCol
            If .Cells(1, i).Value = Trim(vField) Then vFieldNo(j) = i: j = j + 1
        Next
    Next
 
    For i = 2 To cRow
        If .Cells(i, 1).Value = ID Then
            For j = 0 To UBound(vFieldNo)
                vFieldNo(j) = .Cells(i, vFieldNo(j))
            Next
            Exit For
        End If
    Next
 
Get_Records = vFieldNo
 
End With
 
End Function
 
'########################
' 시트에 새로운 레코드 추가 (반드시 첫번째 값은 ID, 나머지 값 순서대로 입력)
' Insert_Record Sheet1, ID, 필드1, 필드2, 필드3, ..
'########################
Sub Insert_Record(WS As Worksheet, ParamArray vaParamArr() As Variant)
 
Dim cID As Long
Dim cRow As Long
Dim vaArr As Variant: Dim i As Long: i = 2
 
With WS
    cRow = Get_InsertRow(WS)
    If InStr(1, .Cells(1, 1).Value, "ID") > 0 Then
        cID = Get_MaxID(WS)
        .Cells(cRow, 1).Value = cID
        For Each vaArr In vaParamArr
            .Cells(cRow, i).Value = vaArr
            i = i + 1
        Next
    Else
        For Each vaArr In vaParamArr
            .Cells(cRow, i - 1).Value = vaArr
            i = i + 1
        Next
    End If
 
End With
 
End Sub
'########################
' 시트에서 ID 를 갖는 레코드의 모든 값 업데이트 (반드시 첫번째 값은 ID여야 하며, 나머지 값을 순서대로 입력)
' Update_Record Sheet1, ID, 필드1, 필드2, 필드3, ...
'########################
Sub Update_Record(WS As Worksheet, ParamArray vaParamArr() As Variant)
 
Dim cRow As Long
Dim i As Long
Dim ID As Variant
 
If IsNumeric(vaParamArr(0)) = True Then ID = CLng(vaParamArr(0)) Else ID = vaParamArr(0)
 
With WS
    cRow = get_UpdateRow(WS, ID)
 
    For i = 1 To UBound(vaParamArr)
        If Not IsMissing(vaParamArr(i)) Then .Cells(cRow, i + 1).Value = vaParamArr(i)
    Next
 
End With
 
End Sub
'########################
' 시트에서 ID 를 갖는 레코드 삭제
' Delete_Record Sheet1, ID
'########################
Sub Delete_Record(WS As Worksheet, ID)
 
Dim cRow As Long
 
If IsNumeric(ID) = True Then ID = CLng(ID)
 
With WS
    cRow = get_UpdateRow(WS, ID)
    .Cells(cRow, 1).EntireRow.Delete
End With
 
End Sub
 
'########################
' 배열의 외부ID키 필드를 본 시트DB와 연결하여 해당 외부ID키의 연관된 값을 배열로 반환
' Array = Connect_DB(Get_DB(Sheet1),2,Sheet2, "필드1, 필드2, 필드3")
'########################
Function Connect_DB(DB As Variant, ForeignID_Fields As Variant, FromWS As Worksheet, Fields As String, Optional IncludeHeader As Boolean = False)
 
Dim cRow As Long: Dim cCol As Long
Dim vForeignID_Fields As Variant: Dim vForeignID_Field As Variant
Dim ForeignID As Variant
Dim vFields As Variant: Dim vField As Variant
Dim vID As Variant: Dim vFieldNo As Variant
Dim Dict As Object
Dim i As Long: Dim j As Long
Dim AddCols As Long
 
 
cRow = UBound(DB, 1)
cCol = UBound(DB, 2)
If InStr(1, Fields, ",") > 1 Then
    AddCols = Len(Fields) - Len(Replace(Fields, ",", "")) + 1
    vFields = Split(Fields, ",")
Else
    AddCols = 1
    vFields = Array(Fields)
End If
 
ReDim Preserve DB(1 To cRow, 1 To cCol + AddCols)
 
Set Dict = Get_Dict(FromWS)
vID = Dict("ID")
 
ReDim vFieldNo(0 To UBound(vFields))
 
For Each vField In vFields
    For i = 1 To UBound(vID)
        If vID(i) = Trim(vField) Then vFieldNo(j) = i: j = j + 1
    Next
Next
 
If InStr(1, ForeignID_Fields, ",") > 0 Then vForeignID_Fields = Split(ForeignID_Fields, ",") Else vForeignID_Fields = Array(ForeignID_Fields)
 
For Each vForeignID_Field In vForeignID_Fields
    For i = 1 To cRow
        If IncludeHeader = True And i = 1 Then ForeignID = "ID" Else ForeignID = DB(i, Trim(vForeignID_Field))
        If Dict.Exists(ForeignID) Then
            For j = 1 To AddCols
                DB(i, cCol + j) = Dict(ForeignID)(vFieldNo(j - 1))
            Next
        End If
    Next
Next
 
Connect_DB = DB
 
End Function
'########################
' 특정 배열에서 Value를 포함하는 레코드만 찾아 다시 배열로 반환
' Array = Filtered_DB(Array, "검색값", False)
'########################
Function Filtered_DB(DB, Value, Optional FilterCol, Optional ExactMatch As Boolean = False) As Variant
 
Dim cRow As Long
Dim cCol As Long
Dim vArr As Variant: Dim s As String: Dim filterArr As Variant:  Dim Cols As Variant: Dim Col As Variant: Dim Colcnt As Long
Dim isDateVal As Boolean
Dim vReturn As Variant: Dim vResult As Variant
Dim Dict As Object: Dim dictKey As Variant
Dim i As Long: Dim j As Long
Dim Operator As String
 
Set Dict = CreateObject("Scripting.Dictionary")
 
If Value <> "" Then
    cRow = UBound(DB, 1)
    cCol = UBound(DB, 2)
    ReDim vArr(1 To cRow)
    For i = 1 To cRow
        s = ""
        For j = 1 To cCol
            s = s & DB(i, j) & "|^"
        Next
        vArr(i) = s
    Next
 
    If IsMissing(FilterCol) Then
        filterArr = vArr
    Else
        Cols = Split(FilterCol, ",")
        ReDim filterArr(1 To cRow)
        For i = 1 To cRow
            s = ""
            For Each Col In Cols
                s = s & DB(i, Trim(Col)) & "|^"
            Next
            filterArr(i) = s
        Next
    End If
 
    If left(Value, 2) = ">=" Or left(Value, 2) = "<=" Or left(Value, 2) = "=>" Or left(Value, 2) = "=<" Then Operator = left(Value, 2) If IsDate(Right(Value, Len(Value) - 2)) Then isDateVal = True ElseIf left(Value, 1) = ">" Or left(Value, 1) = "<" Then
        Operator = left(Value, 1)
        If IsDate(Right(Value, Len(Value) - 1)) Then isDateVal = True
    Else: End If
 
    If Operator <> "" Then
        If isDateVal = False Then
            Select Case Operator
                Case ">"
                    For i = 1 To cRow
                        If CDbl(left(filterArr(i), Len(filterArr(i)) - 2)) > CDbl(Right(Value, Len(Value) - 1)) Then: vArr(i) = left(vArr(i), Len(vArr(i)) - 2): vReturn = Split(vArr(i), "|^"): Dict.Add i, vReturn
                    Next
                Case "<"
                    For i = 1 To cRow
                        If CDbl(left(filterArr(i), Len(filterArr(i)) - 2)) < CDbl(Right(Value, Len(Value) - 1)) Then: vArr(i) = left(vArr(i), Len(vArr(i)) - 2): vReturn = Split(vArr(i), "|^"): Dict.Add i, vReturn Next Case ">=", "=>"
                    For i = 1 To cRow
                        If CDbl(left(filterArr(i), Len(filterArr(i)) - 2)) >= CDbl(Right(Value, Len(Value) - 2)) Then: vArr(i) = left(vArr(i), Len(vArr(i)) - 2): vReturn = Split(vArr(i), "|^"): Dict.Add i, vReturn
                    Next
                 Case "<=", "=<"
                    For i = 1 To cRow
                        If CDbl(left(filterArr(i), Len(filterArr(i)) - 2)) <= CDbl(Right(Value, Len(Value) - 2)) Then: vArr(i) = left(vArr(i), Len(vArr(i)) - 2): vReturn = Split(vArr(i), "|^"): Dict.Add i, vReturn Next End Select Else Select Case Operator Case ">"
                    For i = 1 To cRow
                        If CDate(left(filterArr(i), Len(filterArr(i)) - 2)) > CDate(Right(Value, Len(Value) - 1)) Then: vArr(i) = left(vArr(i), Len(vArr(i)) - 2): vReturn = Split(vArr(i), "|^"): Dict.Add i, vReturn
                    Next
                Case "<"
                    For i = 1 To cRow
                        If CDate(left(filterArr(i), Len(filterArr(i)) - 2)) < CDate(Right(Value, Len(Value) - 1)) Then: vArr(i) = left(vArr(i), Len(vArr(i)) - 2): vReturn = Split(vArr(i), "|^"): Dict.Add i, vReturn Next Case ">=", "=>"
                    For i = 1 To cRow
                        If CDate(left(filterArr(i), Len(filterArr(i)) - 2)) >= CDate(Right(Value, Len(Value) - 2)) Then: vArr(i) = left(vArr(i), Len(vArr(i)) - 2): vReturn = Split(vArr(i), "|^"): Dict.Add i, vReturn
                    Next
                 Case "<=", "=<"
                    For i = 1 To cRow
                        If CDate(left(filterArr(i), Len(filterArr(i)) - 2)) <= CDate(Right(Value, Len(Value) - 2)) Then: vArr(i) = left(vArr(i), Len(vArr(i)) - 2): vReturn = Split(vArr(i), "|^"): Dict.Add i, vReturn Next End Select End If Else If ExactMatch = False Then For i = 1 To cRow If filterArr(i) Like "*" & Value & "*" Then vArr(i) = left(vArr(i), Len(vArr(i)) - 2) vReturn = Split(vArr(i), "|^") Dict.Add i, vReturn End If Next Else For i = 1 To cRow If filterArr(i) Like Value & "|^" Then vArr(i) = left(vArr(i), Len(vArr(i)) - 2) vReturn = Split(vArr(i), "|^") Dict.Add i, vReturn End If Next End If End If If Dict.Count > 0 Then
        ReDim vResult(1 To Dict.Count, 1 To cCol)
        i = 1
        For Each dictKey In Dict.Keys
            For j = 1 To cCol
                vResult(i, j) = Dict(dictKey)(j - 1)
            Next
            i = i + 1
        Next
    End If
 
    Filtered_DB = vResult
Else
    Filtered_DB = DB
End If
 
End Function
 
'########################
' 각 제품별 잔고수량을 계산합니다.
' DB = Get_Balance(DB, shtInventory, 입고수량열번호, 출고수량열번호, 제품ID열번호)
'########################
 
Function Get_Balance(DB, InventoryWS As Worksheet, ColumnIN, ColumnOUT, ColumnID) As Variant
 
Dim InventoryDB As Variant
Dim Dict As Dictionary
Dim cRow As Long: Dim cCol As Long
Dim i As Long: Dim cID
 
If Not IsNumeric(ColumnOUT) Then ColumnOUT = Range(ColumnOUT & 1).Column
If Not IsNumeric(ColumnIN) Then ColumnIN = Range(ColumnIN & 1).Column
If Not IsNumeric(ColumnID) Then ColumnID = Range(ColumnID & 1).Column
 
cRow = UBound(DB, 1)
cCol = UBound(DB, 2)
Set Dict = CreateObject("Scripting.Dictionary")
 
ReDim Preserve DB(1 To cRow, 1 To cCol + 1)
 
For i = 1 To cRow:    Dict.Add DB(i, 1), 0: Next
InventoryDB = Get_DB(InventoryWS)
 
For i = LBound(InventoryDB, 1) To UBound(InventoryDB, 1)
    cID = InventoryDB(i, ColumnID)
    If Dict.Exists(cID) Then
        Dict(cID) = Dict(cID) + InventoryDB(i, CLng(ColumnIN)) - InventoryDB(i, CLng(ColumnOUT))
    End If
Next
 
For i = LBound(DB, 1) To UBound(DB, 1)
    DB(i, cCol + 1) = Dict(DB(i, 1))
Next
 
Get_Balance = DB
 
End Function
 
'########################
' 특정 시트의 DB 정보를 Dictionary로 반환 (이번 예제파일에서만 사용)
' Dict = GetDict(Sheet1)
'########################
Function Get_Dict(WS As Worksheet) As Object
 
Dim cRow As Long: Dim cCol As Long
Dim Dict As Object
Dim vArr As Variant
Dim i As Long: Dim j As Long
 
Set Dict = CreateObject("Scripting.Dictionary")
 
With WS
    cRow = Get_InsertRow(WS) - 1
    cCol = Get_ColumnCnt(WS)
 
    For i = 1 To cRow
        ReDim vArr(1 To cCol - 1)
        For j = 2 To cCol
            vArr(j - 1) = .Cells(i, j)
        Next
        Dict.Add .Cells(i, 1).Value, vArr
    Next
End With
 
Set Get_Dict = Dict
 
End Function
 
'###############################################################
'오빠두엑셀 VBA 사용자지정함수 (https://www.oppadu.com)
'▶ Arr_To_Dict 함수
'▶ 범위를 Dictionary 로 변환합니다.
'▶ 인수 설명
'_____________Arr       : Dictionary로 변환할 배열입니다.
'▶ 사용 예제
'Dict = Arr_To_Dict(Arr)
'##############################################################
Function Arr_To_Dict(Arr As Variant) As Object
 
Dim Dict As Object: Dim vArr As Variant
Dim cCol As Long
Dim i As Long: Dim j As Long
 
Set Dict = CreateObject("Scripting.Dictionary")
cCol = UBound(Arr, 2)
 
For i = LBound(Arr, 1) To UBound(Arr, 1)
        ReDim vArr(1 To cCol - 1)
        For j = 2 To cCol
            vArr(j - 1) = Arr(i, j)
        Next
        Dict.Add Arr(i, 1), vArr
Next
 
Set Arr_To_Dict = Dict
 
End Function
 
'###############################################################
'오빠두엑셀 VBA 사용자지정함수 (https://www.oppadu.com)
'▶ Dict_To_Arr 함수
'▶ Dictionary를 범위로 변환합니다.
'▶ 인수 설명
'_____________Dict       : 배열로 변환할 Dictionary 입니다.
'▶ 사용 예제
'Arr = Dict_To_Arr(Dict)
'##############################################################
Function Dict_To_Arr(Dict As Object) As Variant
 
Dim i As Long: Dim j As Long: Dim dictKey As Variant: Dim cCol As Long
Dim vTest As Variant
i = 1
 
If Dict.Count > 0 Then
    If IsObject(Dict(Dict.Keys()(0))) Then cCol = UBound(Dict(Dict.Keys()(0))) Else cCol = 1
    ReDim vResult(1 To Dict.Count, 1 To cCol + 1)
    For Each dictKey In Dict.Keys
        vResult(i, 1) = dictKey
        If cCol = 1 Then
            vResult(i, 2) = Dict(dictKey)
        Else
            For j = 2 To cCol + 1
                vResult(i, j) = Dict(dictKey)(j - 1)
            Next
        End If
        i = i + 1
    Next
End If
 
Dict_To_Arr = vResult
 
End Function
'########################
' 시트의 특정 필드 내에서 추가되는 값이 고유값인지 확인. 고유값일 경우 TRUE를 반환
' boolean = IsUnique(Sheet1, "사과", 1)
'########################
Function IsUnique(DB As Variant, uniqueVal, Optional ColNo As Long = 1, Optional Exclude) As Boolean
 
Dim endRow As Long
Dim i As Long
 
For i = LBound(DB, 1) To UBound(DB, 1)
    If DB(i, ColNo) = uniqueVal Then
        If Not IsMissing(Exclude) Then
            If Exclude <> uniqueVal Then
                IsUnique = False
                Exit Function
            End If
        Else
            IsUnique = False: Exit Function
        End If
    End If
Next
 
IsUnique = True
 
End Function
 
'###############################################################
'오빠두엑셀 VBA 사용자지정함수 (https://www.oppadu.com)
'▶ Extract_Column 함수
'▶ 배열에서 지정한 열을 추출합니다.
'▶ 인수 설명
'_____________DB        : 특정 열을 추출할 배열입니다.
'_____________Col       : 배열에서 추출할 열의 열번호입니다.
'▶ 사용 예제
'Arr = Extract_Column(Arr, 3) '<- 3번째 열을 추출합니다.
'##############################################################
 
Function Extract_Column(DB As Variant, Col As Long) As Variant
 
Dim i As Long
Dim vArr As Variant
 
ReDim vArr(LBound(DB) To UBound(DB), 1 To 1)
For i = LBound(DB) To UBound(DB)
        vArr(i, 1) = DB(i, Col)
Next
 
Extract_Column = vArr
 
End Function

'유저폼에 추가한 버튼에 개수만큼 아래 명령문을 유저폼에 추가한 뒤, btnXXX를 버튼 이름으로 변경합니다.
Private Sub btnXXX_Exit(ByVal Cancel As MSForms.ReturnBoolean)
OutHover_Css Me.btnXXX
End Sub
 
Private Sub btnXXX_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
OnHover_Css Me.btnXXX
End Sub
 
Private Sub btnXXX_Enter()
OnHover_Css Me.btnXXX
End Sub
 
 
'아래 코드를 유저폼에 추가한 뒤, "btnXXX, btnYYY"를 버튼이름을 쉼표로 구분한 값으로 변경합니다.
Private Sub UserForm_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
Dim ctl As Control
Dim btnList As String: btnList = "btnXXX, btnYYY" ' 버튼 이름을 쉼표로 구분하여 입력하세요.
Dim vLists As Variant: Dim vList As Variant
If InStr(1, btnList, ",") > 0 Then vLists = Split(btnList, ",") Else vLists = Array(btnList)
For Each ctl In Me.Controls
    For Each vList In vLists
        If InStr(1, ctl.Name, Trim(vList)) > 0 Then OutHover_Css ctl
    Next
Next
End Sub
 
'커서 이동시 버튼 색깔을 변경하는 보조명령문을 유저폼에 추가합니다.
Private Sub OnHover_Css(lbl As Control): With lbl:   .BackColor = RGB(211, 240, 224):    .BorderColor = RGB(134, 191, 160): End With: End Sub
Private Sub OutHover_Css(lbl As Control): With lbl:   .BackColor = &H8000000E:    .BorderColor = &H8000000A: End With: End Sub

Option Explicit
 
Function Sort2DArray(DB, ByVal Index As Long, Optional ByVal Order As Integer = -1, Optional ByVal ByColumn As Boolean = False, Optional ByVal lngStart As Long = 0, Optional ByVal lngEnd As Long = 0, Optional THRESHOLD As Long = 20)
 
'###############################################################
'오빠두엑셀 VBA 사용자지정함수 (https://www.oppadu.com)
'수정 및 배포 시 출처를 반드시 명시해야 합니다.
'
'■ Sort2DArray 명령문
'■ 2차원 배열을 오름차순/내림차순 또는 내림차순으로 정렬합니다. 한계점을 설정하여 QuickSort 또는 InsertionSort로 보다 빠르게 정렬할 수 있습니다. 기본 한계점은 20입니다.
'■ 인수 설명
'_____________DB                : 정렬할 배열입니다.
'_____________Index            : DB를 정렬할 기준 순번입니다.
'_____________Order           : [선택인수] 1 이면 내림차순 정렬합니다. 기본값은 -1 (=오름차순) 정렬입니다.
'_____________ByColumn    : [선택인수] True 면 열방향(가로방향) 정렬입니다. 기본값은 FALSE 입니다.
'_____________lngStart        : [선택인수] 정렬을 시작할 시작점입니다. 기본값은 배열의 시작지점입니다.
'_____________lngEnd         : [선택인수] 정렬을 종료할 마지막점입니다. 기본값은 배열의 마지막지점입니다.
'_____________Threshold    : [선택인수] QuickSort와 InsertionSort를 구분할 한계점입니다. 기본값은 20 입니다. Threshold 는 사용되는 데이터의 구성에 따라 다르지만 대부분 10-20 사이의 정수가 사용됩니다.
'■ 반환값
'_____________정렬된 배열을 반환합니다.
'본 명령문은 아래 링크를 참조하여 작성된 명령문입니다.
'https://www.vbforums.com/showthread.php?631366-RESOLVED-Quick-Sort-2D-Array
'###############################################################
 
Dim i As Long: Dim j As Long: Dim k As Long
Dim Pivot: Dim Temp
Dim Stack(1 To 64) As Long: Dim StackPtr As Long
 
If lngStart = 0 Then
    If ByColumn = False Then lngStart = LBound(DB, 1) Else lngStart = LBound(DB, 2)
End If
 
If lngEnd = 0 Then
    If ByColumn = False Then lngEnd = UBound(DB, 1) Else lngEnd = UBound(DB, 2)
End If
 
'가로방향 정렬
  If ByColumn Then
    ReDim Temp(LBound(DB, 1) To UBound(DB, 1))
    Stack(StackPtr + 1) = lngStart
    Stack(StackPtr + 2) = lngEnd
    StackPtr = StackPtr + 2
    Do
      StackPtr = StackPtr - 2
      lngStart = Stack(StackPtr + 1)
      lngEnd = Stack(StackPtr + 2)
      If lngEnd - lngStart < THRESHOLD Then ' 비교 대상의 첫번째 값과 마지막값 차이가 20 미만일 경우 Insertion Sort For j = lngStart + 1 To lngEnd For k = LBound(DB, 1) To UBound(DB, 1) Temp(k) = DB(k, j) Next Pivot = DB(Index, j) For i = j - 1 To lngStart Step -1 If Order >= 0 Then
              If DB(Index, i) <= Pivot Then Exit For Else If DB(Index, i) >= Pivot Then Exit For
            End If
            For k = LBound(DB) To UBound(DB)
              DB(k, i + 1) = DB(k, i)
            Next
          Next
          For k = LBound(DB) To UBound(DB)
            DB(k, i + 1) = Temp(k)
          Next
        Next
      Else
        ' 비교 대상의 첫번째 값과 마지막값 차이가 20 이상일 경우 Quick Sort
        i = lngStart: j = lngEnd
        Pivot = DB(Index, (lngStart + lngEnd) \ 2)
        Do
          If Order >= 0 Then
            Do While (DB(Index, i) < Pivot): i = i + 1: Loop Do While (DB(Index, j) > Pivot): j = j - 1: Loop
          Else
            Do While (DB(Index, i) > Pivot): i = i + 1: Loop
            Do While (DB(Index, j) < Pivot): j = j - 1: Loop
          End If
          If i <= j Then
            If i < j Then For k = LBound(DB) To UBound(DB) Temp(k) = DB(k, i) DB(k, i) = DB(k, j) DB(k, j) = Temp(k) Next End If i = i + 1: j = j - 1 End If Loop Until i > j
        If (lngStart < j) Then
          Stack(StackPtr + 1) = lngStart
          Stack(StackPtr + 2) = j
          StackPtr = StackPtr + 2
        End If
        If (i < lngEnd) Then
          Stack(StackPtr + 1) = i
          Stack(StackPtr + 2) = lngEnd
          StackPtr = StackPtr + 2
        End If
      End If
    Loop Until StackPtr = 0
'세로방향 정렬
Else
    ReDim Temp(LBound(DB, 2) To UBound(DB, 2))
        ' Stack 설정
        Stack(StackPtr + 1) = lngStart
        Stack(StackPtr + 2) = lngEnd
        StackPtr = StackPtr + 2
            Do
                StackPtr = StackPtr - 2
                lngStart = Stack(StackPtr + 1)
                lngEnd = Stack(StackPtr + 2)
                    ' 비교 대상의 첫번째 값과 마지막값 차이가 20 미만일 경우 Insertion Sort
                    If lngEnd - lngStart < THRESHOLD Then For j = lngStart + 1 To lngEnd For k = LBound(DB, 2) To UBound(DB, 2) Temp(k) = DB(j, k) Next Pivot = DB(j, Index) For i = j - 1 To lngStart Step -1 If Order >= 0 Then
                                If DB(i, Index) <= Pivot Then Exit For Else If DB(i, Index) >= Pivot Then Exit For
                              End If
                              For k = LBound(DB, 2) To UBound(DB, 2)
                                DB(i + 1, k) = DB(i, k)
                              Next
                            Next
                            For k = LBound(DB, 2) To UBound(DB, 2)
                              DB(i + 1, k) = Temp(k)
                            Next
                          Next
                Else
                    ' 비교 대상의 첫번째 값과 마지막값 차이가 20 이상일 경우 Quick Sort
                    i = lngStart: j = lngEnd
                    Pivot = DB((lngStart + lngEnd) \ 2, Index)
                        Do
                            If Order >= 0 Then
                                Do While (DB(i, Index) < Pivot): i = i + 1: Loop Do While (DB(j, Index) > Pivot): j = j - 1: Loop
                            Else
                                Do While (DB(i, Index) > Pivot): i = i + 1: Loop
                                Do While (DB(j, Index) < Pivot): j = j - 1: Loop
                            End If
                            If i <= j Then
                                  If i < j Then For k = LBound(DB, 2) To UBound(DB, 2) Temp(k) = DB(i, k) DB(i, k) = DB(j, k) DB(j, k) = Temp(k) Next End If i = i + 1: j = j - 1 End If Loop Until i > j
                            If (lngStart < j) Then
                                  Stack(StackPtr + 1) = lngStart
                                  Stack(StackPtr + 2) = j
                                  StackPtr = StackPtr + 2
                            End If
                            If (i < lngEnd) Then
                                  Stack(StackPtr + 1) = i
                                  Stack(StackPtr + 2) = lngEnd
                                  StackPtr = StackPtr + 2
                            End If
                End If
            Loop Until StackPtr = 0
End If
 
Sort2DArray = DB
 
End Function
 
Sub ArrayToRng(startRng As Range, Arr As Variant, Optional ColumnNo As String = "")
 
'###############################################################
'오빠두엑셀 VBA 사용자지정함수 (https://www.oppadu.com)
'▶ ArrayToRng 함수
'▶ 배열을 범위 위로 반환합니다.
'▶ 인수 설명
'_____________startRng      : 배열을 반환할 기준 범위(셀) 입니다.
'_____________Arr               : 반환할 배열입니다.
'_____________ColumnNo   : [선택인수] 배열의 특정 열을 선택하여 범위로 반환합니다. 여러개 열을 반환할 경우 열 번호를 쉼표로 구분하여 입력합니다.
'                                               값으로 공란을 입력하면 열을 건너뜁니다.
'▶ 사용 예제
'Dim v As Variant
'ReDim v(0 to 1)
''v(0) = "a" : v(1) = "b"
'ArrayToRng Sheet1.Range("A1"), v
'▶ 사용된 보조 명령문
'Extract_Column 함수
'##############################################################
 
On Error GoTo SingleDimension:
 
Dim Cols As Variant: Dim Col As Variant
Dim X As Long: X = 1
If ColumnNo = "" Then
    startRng.Cells(1, 1).Resize(UBound(Arr, 1) - LBound(Arr, 1) + 1, UBound(Arr, 2) - LBound(Arr, 2) + 1) = Arr
Else
    Cols = Split(ColumnNo, ",")
    For Each Col In Cols
        If Trim(Col) <> "" Then
            startRng.Cells(1, X).Resize(UBound(Arr, 1) - LBound(Arr, 1) + 1) = Extract_Column(Arr, CLng(Trim(Col)))
        End If
        X = X + 1
    Next
End If
Exit Sub
 
SingleDimension:
Dim tempArr As Variant: Dim i As Long
ReDim tempArr(LBound(Arr, 1) To UBound(Arr, 1), 1 To 1)
For i = LBound(Arr, 1) To UBound(Arr, 1)
    tempArr(i, 1) = Arr(i)
Next
startRng.Cells(1, 1).Resize(UBound(Arr, 1) - LBound(Arr, 1) + 1, 1) = tempArr
 
End Sub
 
Sub SequenceToRng(startRng As Range, Count As Long, Optional StartNo As Double = 1, Optional Increment As Double = 1, Optional ToRight As Boolean = False)
 
'###############################################################
'오빠두엑셀 VBA 사용자지정함수 (https://www.oppadu.com)
'▶ SequenceToRng 함수
'▶ 순번을 범위로 반환합니다.
'▶ 인수 설명
'_____________startRng      : 배열을 반환할 기준 범위(셀) 입니다.
'_____________Count          : 배열로 반환할 순번의 갯수입니다.
'_____________StartNo        : [선택인수] 순번의 시작 번호입니다. 기본값은 1 입니다.
'_____________Increment    : [선택인수]순번이 증가 또는 감소하는 차이값입니다. 기본값은 1 입니다.
'_____________ToRight        : [선택인수] True일 경우 순번을 오른쪽 방향으로 반환합니다. 기본값은 False(=아래방향)입니다.
'▶ 사용 예제
'SequenceToRng Range("A1")
'##############################################################
 
Dim Arr As Variant: Dim v As Double: v = StartNo - Increment
 
If ToRight = False Then ReDim Arr(1 To Count, 1 To 1) Else ReDim Arr(1 To 1, 1 To Count)
 
If ToRight = False Then
    For i = 1 To Count
        v = v + Increment
        Arr(i, 1) = v
    Next
Else
    For i = 1 To Count
        v = v + Increment
        Arr(1, i) = v
    Next
End If
 
If ToRight = False Then startRng.Cells(1, 1).Resize(Count) = Arr Else startRng.Cells(1, 1).Resize(1, Count) = Arr
 
End Sub
 
Sub ValueToRng(startRng As Range, Count As Long, Value, Optional ToRight As Boolean = False)
 
'###############################################################
'오빠두엑셀 VBA 사용자지정함수 (https://www.oppadu.com)
'▶ ValueToRng 함수
'▶ 고정된 값을 범위에 뿌려줍니다.
'▶ 인수 설명
'_____________startRng      : 값을 뿌려줄 기준 셀 입니다.
'_____________Count          : 뿌려줄 값의 갯수입니다.
'_____________Value           : 뿌려줄 값 입니다.
'_____________ToRight        : [선택인수] True일 경우 값을 오른쪽 방향으로 뿌려줍니다. 기본값은 False(=아래방향)입니다.
'▶ 사용 예제
'ValueToRng Range("A1"), 10, "A"  '<- A1:A10 범위에 "A"를 출력합니다.
'##############################################################
 
If ToRight = False Then startRng.Cells(1, 1).Resize(Count) = Value Else startRng.Cells(1, 1).Resize(1, Count) = Value
 
End Sub
 
Sub RunningSumRng(startRng As Range, Count As Long, _
                                    Optional Offset_Add As Long = -1, Optional Offset_Deduct As Long = 0, _
                                    Optional blnReverse As Boolean = False)
 
'###############################################################
'오빠두엑셀 VBA 사용자지정함수 (https://www.oppadu.com)
'▶ RunningSumRng 함수
'▶ 시작셀을 기준으로 더할위치/뺄위치를 지정하여 누계를 계산합니다.
'▶ 인수 설명
'_____________startRng               : 누계를 계산할 기준 셀입니다.
'_____________Count                   : 누계를 계산할 범위의 갯수입니다.
'_____________Offset_Add          : 더할 값이 입력된 열의 상대 위치입니다. (음수는 왼쪽방향, 양수는 오른쪽방향입니다. 기본값은 -1, 한칸 왼쪽에 있는 값을 더합니다.)
'_____________Offset_Deduct     : [선택인수] 뺄 값이 입력된 열의 상대위치입니다. 기본값은 없음입니다.
'_____________blnReverse            : [선택인수] True일 경우 시작셀을 맨 아래로 부터 시작하여 위로 올라가며 누계를 계산합니다. 기본값은 False 입니다.
'▶ 사용 예제
'RunningSumRng Range("C1"), 10,   '<- C1:C10 범위에 B1:B10을 참조하여 누계를 계산합니다.
'##############################################################
 
Dim T As Double
Dim vArr As Variant
Dim fR As Single: Dim fS As Long: Dim fE As Long
 
If blnReverse = False Then fR = 1 Else fR = -1
If Count < 1 Then Count = 1
 
ReDim vArr(1 To Count, 1 To 1)
    If fR = 1 Then fS = 1: fE = Count Else fS = Count: fE = 1
 
    If Offset_Deduct <> 0 Then
        For i = 1 To Count
            T = T + startRng.Offset((i - 1) * fR, Offset_Add).Value - startRng.Offset((i - 1) * fR, Offset_Deduct).Value
            vArr(i, 1) = T
        Next
    Else
        For i = 1 To Count
            T = T + startRng.Offset((i - 1) * fR, Offset_Add).Value
            vArr(i, 1) = T
        Next
    End If
 
If fR = 1 Then
    startRng.Resize(Count) = vArr
Else
    fE = UBound(vArr, 1)
    fS = LBound(vArr, 1)
    For i = fS To (fE - fS) \ 2 + fS
        T = vArr(fE, 1)
        vArr(fE, 1) = vArr(i, 1)
        vArr(i, 1) = T
        fE = fE - 1
    Next
    startRng.Offset(-Count + 1).Resize(Count) = vArr
End If
 
End Sub
 
Function IsUniqueArray(Arr As Variant, Optional ColNo As String = "") As Boolean
 
'###############################################################
'오빠두엑셀 VBA 사용자지정함수 (https://www.oppadu.com)
'▶ IsUniqueArray 함수
'▶ 배열에서 지정한 열이 하나의 값으로만 입력되어 있는지 확인합니다.
'▶ 인수 설명
'_____________Arr               : 배열입니다.
'_____________ColNo          : [선택인수] 하나의 값만 입력되어 있는지 확인할 열 번호입니다. 쉼표로 구분하여 여러개의 열을 지정할 수 있습니다. AND 조건으로 고유여부를 조회합니다. 기본값은 배열의 최초 열번호입니다.
'▶ 사용 예제
'Debug.Print IsUniqueArray (DB, 2)  '<- 배열의 두번째 열의 값이 하나로만 이루어져있는지 확인합니다. '▶ 사용된 보조함수 'ArrayDimension 함수 '############################################################## Dim D As Long: Dim i As Long Dim c As Variant Dim vCols As Variant: Dim vCol As Variant Dim sTemp As String D = ArrayDimension(Arr) If ColNo = "" Then If D > 1 Then ColNo = LBound(Arr, 2)
vCols = Split(ColNo, ",")
 
If D = 1 Then
    c = Arr(LBound(Arr))
    For i = LBound(Arr) To UBound(Arr)
        If Arr(i) <> c Then IsUniqueArray = False: Exit Function
    Next
Else
    For Each vCol In vCols
        sTemp = sTemp & Arr(LBound(Arr, 1), CLng(Trim(vCol)))
    Next
    c = sTemp
    For i = LBound(Arr, 1) To UBound(Arr, 1)
        sTemp = ""
        For Each vCol In vCols
            sTemp = sTemp & Arr(i, CLng(Trim(vCol)))
        Next
        If c <> sTemp Then IsUniqueArray = False: Exit Function
    Next
End If
 
IsUniqueArray = True
 
End Function
Function IsDistinctArray(Arr As Variant, Optional ColNo As String = "") As Boolean
 
'###############################################################
'오빠두엑셀 VBA 사용자지정함수 (https://www.oppadu.com)
'▶ IsDistinctArray 함수
'▶ 배열에서 지정한 열의 값들이 모두 고유한 값들만 입력되어 있는지 확인합니다.
'▶ 인수 설명
'_____________Arr               : 배열입니다.
'_____________ColNo          : [선택인수] 값들이 고유한지 여부를 조회할 열 번호입니다. 쉼표로 구분하여 여러개의 열을 지정할 수 있습니다. AND 조건으로 고유여부를 조회합니다. 기본값은 배열의 최초 열번호입니다.
'▶ 사용 예제
'Debug.Print IsDistinctArray(DB, 2)  '<- 배열의 두번째 열의 값들이 고유한지 검사합니다. '▶ 사용된 보조함수 'ArrayDimension 함수 '############################################################## Dim Dict As Dictionary Dim vCols As Variant: Dim vCol As Variant Dim sTemp As String: Dim i As Long Set Dict = New Dictionary If ColNo = "" Then If ArrayDimension(Arr) > 1 Then ColNo = LBound(Arr, 2)
 
vCols = Split(ColNo, ",")
 
On Error GoTo Duplicate:
 
If ArrayDimension(Arr) = 1 Then
    For i = LBound(Arr) To UBound(Arr)
        Dict.Add Arr(i), 0
    Next
Else
    For i = LBound(Arr, 1) To UBound(Arr, 1)
        sTemp = ""
        For Each vCol In vCols
            sTemp = sTemp & Arr(i, CLng(Trim(vCol)))
        Next
        Dict.Add sTemp, 0
    Next
End If
 
IsDistinctArray = True
 
Exit Function
 
Duplicate:
    IsDistinctArray = False
 
End Function
 
Sub ClearContentsBelow(startRng As Range, Optional ColNo, Optional BaseCol As Long = 0)
 
'###############################################################
'오빠두엑셀 VBA 사용자지정함수 (https://www.oppadu.com)
'▶ ClearContentsBelow 함수
'▶ 기준셀부터 특정열까지 아래로 입력된 데이터를 모두 초기화합니다. (값만 초기화되며 서식은 그대로 유지됩니다.)
'▶ 인수 설명
'_____________startRng      : 기준셀입니다.
'_____________ColNo          : [선택인수] 기준셀로부터 삭제될 열번호(또는 알파벳)입니다. 기본값은 기준셀로부터 연속된 범위의 우측 마지막셀 열번호를 반환합니다.
'_____________BaseCol       : [선택인수] 기준셀 아래로 연속된 데이터를 참조할 기준열번호 입니다. 기본값은 기준셀의 열번호입니다.
'▶ 사용 예제
'ClearContentsBelow Range("A5"), "F"   '<- A5~F열까지 아래로 입력된 데이터를 초기화합니다.
'##############################################################
 
Dim WS As Worksheet: Dim lastRow As Long: Set WS = startRng.Parent
If IsMissing(ColNo) Then ColNo = WS.Cells(startRng.Row, WS.Columns.Count).End(xlToLeft).Column
If Not IsNumeric(ColNo) Then ColNo = Range(ColNo & 1).Column
If BaseCol = 0 Then BaseCol = startRng.Column Else BaseCol = startRng.Column + BaseCol - 1
lastRow = WS.Cells(WS.Rows.Count, BaseCol).End(xlUp).Row
If lastRow < startRng.Row Then Exit Sub
WS.Range(startRng, WS.Cells(lastRow, ColNo)).ClearContents
 
End Sub
 
'###############################################################
'오빠두엑셀 VBA 사용자지정함수 (https://www.oppadu.com)
'▶ ArrayDimension 함수
'▶ 배열의 차원수를 반환합니다.
'▶ 인수 설명
'_____________vaArray     : 차원을 검토할 배열을 입력합니다.
'###############################################################
Function ArrayDimension(vaArray As Variant) As Integer
 
Dim i As Integer: Dim X As Integer
 
On Error Resume Next
 
Do
    i = i + 1
    X = UBound(vaArray, i)
Loop Until Err.Number <> 0
 
Err.Clear
 
ArrayDimension = i - 1
 
End Function
 
Function ShapeInRange(Rng As Range, _
                Optional iRed As Long = 255, _
                Optional iGreen As Long = 0, _
                Optional iBlue As Long = 0, _
                Optional FillVisible As MsoTriState = msoTrue, _
                Optional LineVisible As MsoTriState = msoTrue, _
                Optional Transparent As Double = 0.95, _
                Optional LineWeight As Double = 0.5, _
                Optional DashType As MsoLineDashStyle = msoLineDash, _
                Optional ShapeType As MsoAutoShapeType = msoShapeRectangle, _
                Optional ActivateSheet As Boolean = True) As Shape
 
'###############################################################
'오빠두엑셀 VBA 사용자지정함수 (https://www.oppadu.com)
'수정 및 배포 시 출처를 반드시 명시해야 합니다.
'
'■ ShapeInRange 명령문
'■ 선택된 범위 안에 도형을 삽입합니다.
'■ 사용방법
''아래 명령문을 유저폼 모듈안에 붙여넣기 한 뒤, '리스트박스' 를 실제 적용할 리스트박스 이름으로 변경합니다.
''----------------------------------------------------------------------------------------------------
'Dim Shp As Shape
'Set Shp = ShapeInRange(Range("A1"))
''-----------------------------------------------------------------------------------------------------
'▶ 인수 설명
'_____________Rng               : 도형을 삽입할 범위입니다.
'_____________iRed               : [선택인수] 삽입할 도형의 RGB, R 값입니다. 기본값은 255 입니다.
'_____________iGreen           : [선택인수] 삽입할 도형의 RGB, G 값입니다. 기본값은 0 입니다.
'_____________iBlue              : [선택인수] 삽입할 도형의 RGB, B 값입니다. 기본값은 0 입니다.
'_____________FillVisible       : [선택인수] 채우기 여부입니다. 기본값은 TRUE 입니다.
'_____________LineVisible     : [선택인수] 윤곽선 여부입니다. 기본값은 TRUE 입니다.
'_____________Transparent  : [선택인수] 채우기 투명도입니다. 기본값은 0.25 입니다.
'_____________LineWeight   : [선택인수] 윤곽선 두께입니다. 기본값은 0.5 입니다.
'_____________DashType      : [선택인수] 윤곽선 스타일입니다. 기본값은 점선입니다.
'_____________ShapeType    : [선택인수] 도형 모양입니다. 기본값은 직사각형입니다.
'_____________AvtiveSheet   : [선택인수] 도형삽입 후 삽입된 시트 활성화여부입니다. 기본값은 True 입니다.
'###############################################################
 
Dim Shp As Shape
Dim WS As Worksheet
 
Set WS = Rng.Parent
 
With Rng
    Set Shp = WS.Shapes.AddShape(ShapeType, .left, .top, .Width, .Height)
End With
 
With Shp
    With .Fill
        .Visible = FillVisible
        .ForeColor.RGB = RGB(iRed, iGreen, iBlue)
        .Transparency = Transparent
    End With
    With .Line
        .Visible = LineVisible
        .ForeColor.RGB = RGB(iRed, iGreen, iBlue)
        .Weight = LineWeight
        .DashStyle = DashType
    End With
End With
 
Set ShapeInRange = Shp
If ActivateSheet = True Then Shp.Parent.Activate
 
End Function

Option Explicit
 
'########################
' 콤보박스를 DB 값으로 갱신
' Update_Cbo cboBox, DB, "1"
'########################
Sub Update_Cbo(cboBox As MSForms.ComboBox, DB As Variant, Optional DisplayCol As Long = 1, Optional SetDefault As Boolean = False)
 
Dim colCount As Long
Dim colWidths As String
Dim i As Long
 
colCount = UBound(DB, 2)
 
With cboBox
    .ColumnCount = colCount
    For i = 1 To colCount
        If DisplayCol = i Then colWidths = colWidths & .Width - 15 & "," Else colWidths = colWidths & "0,"
    Next
    colWidths = left(colWidths, Len(colWidths) - 1)
    .List = DB
    .ColumnWidths = colWidths
    If SetDefault = True Then .ListIndex = 0
End With
 
End Sub
 
'########################
' 콤보박스의 특정 필드 값을 참조하여 값을 선택
' Select_CboItm cboBox, 1, 1
'########################
Sub Select_CboItm(cboBox As MSForms.ComboBox, ID, Optional ColNo As Long = 1)
 
Dim i As Long
 
If IsNumeric(ID) Then ID = CLng(ID)
 
With cboBox
    For i = 0 To .ListCount - 1
        If .List(i, ColNo - 1) = ID Then .ListIndex = i
    Next
End With
 
End Sub
 
'########################
' 리스트박스를 DB 값으로 갱신
' Update_List ListBox, DB, "0pt; 80pt; 50pt"
'########################
Sub Update_List(lstBox As MSForms.ListBox, DB As Variant, Widths As String)
 
With lstBox
    .Clear
    .ColumnWidths = Widths
    If Not IsEmpty(DB) Then
        .ColumnCount = UBound(DB, 2)
        .List = DB
    End If
End With
 
End Sub
 
'########################
' 리스트박스의 아이템 목록을 배열로 반환
' Array = Get_ListItm listbox
'########################
Function Get_ListItm(lstBox As Control, Optional blnAll As Boolean = False) As Variant
 
Dim i As Long: Dim j As Long
Dim vaArr As Variant
 
    With lstBox
        If blnAll = False Then
            If .ListIndex <> -1 Then
            ReDim vaArr(0 To .ColumnCount - 1)
                For i = 0 To .ListCount - 1
                    If .Selected(i) Then
                        For j = 0 To .ColumnCount - 1
                            vaArr(j) = .List(i, j)
                        Next
                        Exit For
                    End If
                Next
            End If
        Else
            ReDim vaArr(0 To .ListCount - 1, 0 To .ColumnCount - 1)
                For i = 0 To .ListCount - 1
                    For j = 0 To .ColumnCount - 1
                        vaArr(i, j) = .List(i, j)
                    Next
                Next
        End If
    End With
 
Get_ListItm = vaArr
 
End Function
 
'########################
' 리스트박스의 첫번째필드 ID를 참조하여 해당 ID 값을 선택
' Select_ListItm ListBox, ID
'########################
Function Select_ListItm(lstBox As Control, ID, Optional ColNo As Long = 1)
 
Dim i As Long
 
If IsNumeric(ID) Then ID = CLng(ID)
 
With lstBox
    For i = 0 To .ListCount - 1
        If .List(i, ColNo - 1) = ID Then .Selected(i) = True: Exit For
    Next
End With
 
End Function
 
'########################
' 리스트박스 활성화
' Active_ListBox ( ListBox, Select_ListItm(ListBox, ID) )
'########################
Function Active_ListBox(lstBox As Control, Optional Index As Long = 0)
 
If lstBox.ListCount > 0 Then lstBox.Selected(Index) = True
 
End Function
 
'########################
' 현재 선택된 값의 순번 확인
' i = Get_ListIndex(ListBox)
'########################
Function Get_ListIndex(lstBox As Control)
 
Dim i As Long
With lstBox
    If .ListIndex <> -1 Then
        For i = 0 To .ListCount - 1
            If .Selected(i) Then Get_ListIndex = i: Exit For
        Next
    End If
End With
 
End Function
 
'########################
' 리스트 박스가 선택되어 있는지 여부 확인
' boolean = isListBoxSelected(ListBox1)
'########################
 
Function isListBoxSelected(ListBox As MSForms.ListBox) As Boolean
 
Dim i As Long
 
For i = 0 To ListBox.ListCount - 1
If ListBox.Selected(i) Then isListBoxSelected = True: Exit Function
Next
 
isListBoxSelected = False
 
End Function
 
 '########################
' 유저폼에서 해당 컨트롤 버튼 값 초기화
' Clear_Ctrls ( Userform1, "Label", "이름" )  ' 유저폼에서 "이름"이 들어가는 라벨 제외 모든 label 제거
' 컨트롤 이름에는 와일드카드(*,?) 사용가능 (예: txt* 는 txt로 시작하는 모든 버튼을 의미)
' 컨트롤 종류 :
' Label, Frame, TextBox, CommandButton, ComboBox, TabStrip, ListBox,
' MultiPage, CheckBox, ScrollBar, OptionButton, SpinButton, ToggleButton, Image
'########################
Sub Clear_Ctrls(frm As UserForm, CtlType As String, Optional Exclude As String)
 
Dim ctl As Control
Dim Excs As Variant: Dim Exc As Variant
Dim blnPass As Boolean
Dim vaType As Variant: Dim vType As Variant
 
If InStr(1, Exclude, ",") > 0 Then: Excs = Split(Exclude, ","): Else Excs = Array(Exclude)
If InStr(1, CtlType, ",") > 0 Then: vaType = Split(CtlType, ","): Else vaType = Array(CtlType)
 
For Each vType In vaType
    For Each ctl In frm.Controls
        If ctl.Name Like Trim(vType) Then
            blnPass = False
            For Each Exc In Excs
                If ctl.Name Like Trim(Exc) Then blnPass = True: Exit For
            Next
            If blnPass = False Then ctl.Value = ""
        End If
    Next
Next
 
End Sub
 
 '########################
' 유저폼의 컨트롤 중 비어있는 컨트롤이 있는지 확인(오류방지)
' blnCheck = IsEmpty_Ctrls ( Userform1, "Label", "이름" )  ' 유저폼에서 "이름"이 들어가는 라벨 제외 모든 label 제거
' 컨트롤 이름에는 와일드카드(*,?) 사용가능 (예: txt* 는 txt로 시작하는 모든 버튼을 의미)
' 컨트롤 종류 :
' Label, Frame, TextBox, CommandButton, ComboBox, TabStrip, ListBox,
' MultiPage, CheckBox, ScrollBar, OptionButton, SpinButton, ToggleButton, Image
'########################
Function IsEmpty_Ctrls(frm As UserForm, CtlType As String, Optional Exclude As String)
 
Dim ctl As Control
Dim vaType As Variant: Dim vType As Variant
 
If InStr(1, CtlType, ",") > 0 Then: vaType = Split(CtlType, ","): Else vaType = Array(CtlType)
 
For Each vType In vaType
    For Each ctl In frm.Controls
        If ctl.Name Like Trim(vType) And ctl.Name <> Exclude Then
            If ctl.Value = "" Then IsEmpty_Ctrls = True: Exit Function
        End If
    Next
Next
 
IsEmpty_Ctrls = False
 
End Function

Option Explicit
 
'###############################################################
'오빠두엑셀 VBA 사용자지정함수 (https://www.oppadu.com)
'수정 및 배포 시 출처를 반드시 명시해야 합니다.
'
'■ HookListBoxScroll & UnHookListBoxScroll 명령문
'■ 유저폼에 사용된 리스트박스가 마우스 휠로 스크롤 되도록 후킹 / 후킹해제하는 명령문입니다.
'■ 사용방법
''아래 명령문을 유저폼 모듈안에 붙여넣기 한 뒤, '리스트박스' 를 실제 적용할 리스트박스 이름으로 변경합니다.
''----------------------------------------------------------------------------------------------------
'Private Sub 리스트박스_Exit(ByVal Cancel As MSForms.ReturnBoolean)
'UnhookListBoxScroll
'End Sub
'Private Sub 리스트박스_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
'HookListBoxScroll Me, Me.리스트박스
'End Sub
''-----------------------------------------------------------------------------------------------------
'
'본 명령문은 아래 링크를 참조하여 작성된 명령문입니다.
'https://social.msdn.microsoft.com/Forums/en-US/7d584120-a929-4e7c-9ec2-9998ac639bea/mouse-scroll-in-userform-listbox-in-excel-2010?forum=isvvba
'###############################################################
 
Private Type POINTAPI
        X As Long
        Y As Long
End Type
 
Private Type MOUSEHOOKSTRUCT
        pt As POINTAPI
        hwnd As Long
        wHitTestCode As Long
        dwExtraInfo As Long
End Type
 
#If VBA7 Then
Private Declare PtrSafe Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As LongPtr
Private Declare PtrSafe Function GetWindowLong Lib "user32.dll" Alias "GetWindowLongA" (ByVal hwnd As LongPtr, ByVal nIndex As LongPtr) As LongPtr
Private Declare PtrSafe Function SetWindowsHookEx Lib "user32" Alias "SetWindowsHookExA" (ByVal idHook As Long, ByVal lpfn As LongPtr, ByVal hmod As LongPtr, ByVal dwThreadId As Long) As LongPtr
Private Declare PtrSafe Function CallNextHookEx Lib "user32" (ByVal hHook As LongPtr, ByVal nCode As Long, ByVal wParam As LongPtr, lParam As Any) As LongPtr
Private Declare PtrSafe Function UnhookWindowsHookEx Lib "user32" (ByVal hHook As LongPtr) As LongPtr
Private Declare PtrSafe Function WindowFromPoint Lib "user32" (ByVal xPoint As Long, ByVal yPoint As Long) As LongPtr
Private Declare PtrSafe Function GetCursorPos Lib "user32.dll" (ByRef lpPoint As POINTAPI) As LongPtr
#Else
Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
Private Declare Function GetWindowLong Lib "user32.dll" Alias "GetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long) As Long
Private Declare Function SetWindowsHookEx Lib "user32" Alias "SetWindowsHookExA" (ByVal idHook As Long, ByVal lpfn As Long, ByVal hmod As Long, ByVal dwThreadId As Long) As Long
Private Declare Function CallNextHookEx Lib "user32" (ByVal hHook As Long, ByVal nCode As Long, ByVal wParam As Long, lParam As Any) As Long
Private Declare Function UnhookWindowsHookEx Lib "user32" (ByVal hHook As Long) As Long
Private Declare Function WindowFromPoint Lib "user32" (ByVal xPoint As Long, ByVal yPoint As Long) As Long
Private Declare Function GetCursorPos Lib "user32.dll" (ByRef lpPoint As POINTAPI) As Long
#End If
 
Private Const WH_MOUSE_LL As Long = 14
Private Const WM_MOUSEWHEEL As LongPtr = &H20A
Private Const HC_ACTION As LongPtr = 0
Private Const GWL_HINSTANCE As LongPtr = (-6)
 
Private mLngMouseHook As LongPtr
Private mListBoxHwnd As LongPtr
Private mbHook As Boolean
Private mCtl As MSForms.Control
Dim n As LongPtr
 
Sub HookListBoxScroll(frm As Object, ctl As MSForms.Control)
Dim lngAppInst As LongPtr
Dim hwndUnderCursor As LongPtr
Dim tPT As POINTAPI
     GetCursorPos tPT
     hwndUnderCursor = WindowFromPoint(tPT.X, tPT.Y)
     If Not frm.ActiveControl Is ctl Then
             ctl.SetFocus
     End If
     If mListBoxHwnd <> hwndUnderCursor Then
             UnhookListBoxScroll
             Set mCtl = ctl
             mListBoxHwnd = hwndUnderCursor
             lngAppInst = GetWindowLong(mListBoxHwnd, GWL_HINSTANCE)
             If Not mbHook Then
                     mLngMouseHook = SetWindowsHookEx( _
                                                     WH_MOUSE_LL, AddressOf MouseProc, lngAppInst, 0)
                     mbHook = mLngMouseHook <> 0
             End If
     End If
End Sub
 
Sub UnhookListBoxScroll()
     If mbHook Then
                Set mCtl = Nothing
             UnhookWindowsHookEx mLngMouseHook
             mLngMouseHook = 0
             mListBoxHwnd = 0
             mbHook = False
        End If
End Sub
 
Private Function MouseProc(ByVal nCode As Long, ByVal wParam As LongPtr, ByRef lParam As MOUSEHOOKSTRUCT) As LongPtr
Dim idx As LongPtr
        On Error GoTo errH
     If (nCode = HC_ACTION) Then
             If WindowFromPoint(lParam.pt.X, lParam.pt.Y) = mListBoxHwnd Then
                     If wParam = WM_MOUSEWHEEL Then
                                MouseProc = True
                                If lParam.hwnd > 0 Then idx = -1 Else idx = 1
                             idx = idx + mCtl.TopIndex
                             If idx >= 0 Then mCtl.TopIndex = idx
                                Exit Function
                     End If
             Else
                     UnhookListBoxScroll
             End If
     End If
     MouseProc = CallNextHookEx( _
                             mLngMouseHook, nCode, wParam, ByVal lParam)
     Exit Function
errH:
     UnhookListBoxScroll
End Function