VBA UDF 결과 배열을 Sheet에 출력하기

Excel 에 도입된 신규 함수중 일부는 Dynamic Array 결과를 Sheet에 출력하는데,

UDF에서 이와 비슷한 기능을 할 수 있도록 하는 방법입니다.

 

장점 : 함수 결과가 배열인 경우 바로 Sheet에 쓸 수 있다.

단점 : 결과 범위가 축소된 경우 줄어든 부분에 대해서 값을 지울 수는 없다.

      -> 사용상 주의하지 않은 경우 변경된 결과에 이전 결과의 잔상이 남음...

(현재 EGTools에는 완벽하지는 않지만 기존 자료를 자동으로 지울 수 있도록 적용되어 있습니다.)

 

기본적인 개념은 아래 출처에서 착안하여 시행착오를 거쳐 정리한 결과입니다.

https://stackoverflow.com/a/37344343

 

처리 과정은 대강 이렇게 진행됩니다.

1. Global 변수에 결과를 전달할 배열 선언 : vWriteRange

2. UDF에서 처리된 결과를 선언된 Global 변수에 저장
3. UDF에서 Array결과를 처리해줄 공통 함수 호출

4. Sheet에 출력할 배열은 아래 그림처럼 3부분으로 나누어 처리

 

글로벌 변수 선언

사용자 함수(UDF)에서 시트에 배열을 출력해야 할 경우 그 결과를 담을 변수입니다.

Public vWriteRange As Variant

 

UDF에서 처리

아래는 Microsoft 365용 Excel에 추가된 VSTACK함수의 호환함수 코드 샘플입니다.

함수에서 본연의 기능을 모두 수행하고 그 결과를 배열함수 처리 공통함수에 넘겨줍니다.

맨 마지막에 호출하는 getArrayResult가 배열결과를 처리하는 공통함수입니다.

Public Function VSTACK(ParamArray arg_Arrays() As Variant) As Variant
'/////////////////////////////////////////////////////////////////////////////'
'//     Microsoft 365용 Excel에서 지원하는 VSTACK 함수를 구현'
'/////////////////////////////////////////////////////////////////////////////'
    
    Dim LbArg As Long, UbArg As Long, nArg As Long, numCol As Long
    Dim tmpArray As Variant, rArray As Variant, i As Long, j As Long
    
    LbArg = LBound(arg_Arrays)
    UbArg = UBound(arg_Arrays)
    If IsMissing(arg_Arrays) Then VSTACK = CVErr(xlErrValue): Exit Function
    
    If TypeName(arg_Arrays(LbArg)) = "Range" Then
        rArray = Intersect(arg_Arrays(LbArg), _
                 arg_Arrays(LbArg).Parent.UsedRange).Value2
    ElseIf isArray(arg_Arrays(LbArg)) Then
        rArray = arg_Arrays(LbArg)
    Else
        VSTACK = CVErr(xlErrValue)
        Exit Function
    End If
    
    For nArg = LbArg + 1 To UbArg
        If TypeName(arg_Arrays(nArg)) = "Range" Then
            Set arg_Arrays(nArg) = Intersect(arg_Arrays(nArg), _
                                   arg_Arrays(nArg).Parent.UsedRange)
        End If
        rArray = CombineArray(rArray, arg_Arrays(nArg), True)
        If IsError(rArray) Then VSTACK = rArray: Exit Function
    Next nArg

    If UBound(rArray, 1) > 1048576 Then _
                         VSTACK = CVErr(2045): Exit Function     'xlErrSpill
    If UBound(rArray, 2) > 16384 Then _
                         VSTACK = CVErr(2045): Exit Function     'xlErrSpill
    
LAST_RUN:
    VSTACK = getArrayResult(rArray, Application.Caller.Formula, "VSTACK")
    
End Function

 

공통처리 함수

전달된 배열과, 사용된 수식, 호출한 함수명으로 가지고 처리합니다.

사용된 수식과 호출 함수명으로 함수가 직접 사용된 것이면 Sheet에 배열을 출력하고,

다른 함수의 안에서 사용된 것이면 결과를 배열 그대로 다른 함수에 넘겨줍니다.

코드에서 isNested(sFormula, sFunction)는 사용된 함수가 다른 함수 내에서 사용되었는지 판정하는 함수입니다.

 

Function getArrayResult(argArray As Variant, sFormula As String, sFunction As String)
    Dim rArray As Variant

    If IsError(argArray) Then getArrayResult = argArray: Exit Function
    
    If TypeName(argArray) = "Range" Then
        If argArray.Cells.Count = 1 Then _
                        getArrayResult = argArray.Value2: Exit Function
        rArray = argArray.Value2
    Else
        If Not isArray(argArray) Then _
                        getArrayResult = argArray: Exit Function
        rArray = argArray
    End If
    
    If isNested(sFormula, sFunction) Then
        getArrayResult = rArray
    Else
        If UBound(rArray, 1) <> LBound(rArray, 1) Or _
           UBound(rArray, 2) <> UBound(rArray, 1) Then
            vWriteRange = rArray
            Evaluate ("WriteRange(" & """'" & Application.Caller.Parent.Name _
            & "'!" & Application.Caller.Address(False, False) & """)")
            Erase vWriteRange
        End If
        
        If IsEmpty(rArray(LBound(rArray, 1), LBound(rArray, 2))) Then
            getArrayResult = vbNullString
        Else
            getArrayResult = rArray(LBound(rArray, 1), LBound(rArray, 2))
        End If
    End If
End Function

 

Sheet에 배열결과를 출력

최종적으로 Sheet에 결과 배열을 기록하는 부분으로 3개의 블럭으로 나누어 처리합니다.

절대로 결과 배열을 한방에 Sheet에 출력하지 않도록 합니다. (Excel Crash!!)

 

Function WriteRange(Optional CallerAddress As String = vbNullString)

    Dim cCell As Range  '함수를 호출한 셀
    '세로줄, 가로줄, 나머지영역
    Dim vValue As Variant, hValue As Variant, rValue As Variant     
    Dim iRow As Long, iCol As Long, r As Long, c As Long
    Dim iLBr As Long, iUBr As Long, iLBc As Long, iUBc As Long
    
    On Error GoTo ERR_EXIT
     
    iLBr = LBound(vWriteRange, 1): iUBr = UBound(vWriteRange, 1)
    iLBc = LBound(vWriteRange, 2): iUBc = UBound(vWriteRange, 2)
    iRow = iUBr - iLBr + 1: iCol = iUBc - iLBc + 1
    If iRow = 1 And iCol = 1 Then Exit Function
    
    If CallerAddress = "" Then
        Set cCell = Range(vWriteRange(iLBr, iLBc))
    Else   
        Set cCell = Range(CallerAddress)
    End If
    If cCell Is Nothing Then GoTo ERR_EXIT
    
    '*** 아래처럼 3분할하여 처리하지 않고 한방에 처리할 경우 Excel Crash 발생함.
    '*** 절대금지 : cCell.Resize(iRow, iCol) = vWriteRange
    If iRow > 1 Then ReDim vValue(1 To iRow - 1, 1 To 1)
    If iCol > 1 Then ReDim hValue(1 To 1, 1 To iCol - 1)
    If iRow > 1 And iCol > 1 Then ReDim rValue(1 To iRow - 1, 1 To iCol - 1)
    
    For r = 1 To iRow: For c = 1 To iCol
        If r = 1 Then If c > 1 Then hValue(r, c - 1) = _
                           vWriteRange(iLBr + r - 1, iLBc + c - 1)
        If c = 1 Then If r > 1 Then vValue(r - 1, c) = _
                           vWriteRange(iLBr + r - 1, iLBc + c - 1)
        If r > 1 And c > 1 Then rValue(r - 1, c - 1) = _
                           vWriteRange(iLBr + r - 1, iLBc + c - 1)
    Next: Next
    
    If iRow > 1 Then cCell.Offset(1, 0).Resize(UBound(vValue, 1), 1) = vValue
    If iCol > 1 Then cCell.Offset(0, 1).Resize(1, UBound(hValue, 2)) = hValue
    If iRow > 1 And iCol > 1 Then cCell.Offset(1, 1).Resize(iRow - 1, iCol - 1) _
                                                                      = rValue

    WriteRange = True
    Set cCell = Nothing
    Exit Function
    
ERR_EXIT:
    Debug.Print cCell.Address(False, False) & "에 WriteRange 실패"
    WriteRange = False
    Set cCell = Nothing

End Function