Chia sẻ Code VBA: In thử kết quả Mảng trong cửa sổ Immediate (Update: 24/11/2018)

Sanbi

New Member
Hội viên mới
Chia sẻ cho mọi người một code xem trước kết quả trong cửa sổ Immediate
Code sẽ giúp các bạn có thể xem trước kết quả của một mảng nhanh hơn. Không cần phải Active Workbook mỗi lần chạy code mà có thể xem kết quả ngay trong cửa sổ lập trình VBA.
Bản Cập nhật mới: 24/11/2018 18:00
oops.gif

Sử dụng:
- Với mảng:
dbPrint [im, arrayHeader ,punc , reTypeArray2D, widthMinCol, widthMaxCol , puncMain, puncType,TypeMaxCol]
- Với các đối tượng đơn: số, chuỗi, double, variant,... :
dbPrint<..> thay cho: Debug.Print <..> (mỗi lần kiểm thử mà đánh chữ "debug" lại còn "." rồi "print")
1. [im] - Đối tượng để in ( hãy thử nhập vào bất kì đối tượng nào)
2. [arrayHeader] - mảng có /không tiêu đề
3. [punc] - thêm ký tự đứng trước ("" thì tự động đánh thứ tự)
4. [reTypeArray2D] - trả về / không trả về Type trong mảng 2D
5. [widthMinCol ] - giới hạn độ rộng nhỏ nhất
6. [widthMaxCol ] - giới hạn độ rộng của chuỗi dài nhất trong cột của mảng
7. [puncMain] - Màu mè hoa lá cành (Thử "<>") (cột có dữ liệu ngắn dài khác nhau mới thấy nhé)
8. [puncType] - dấu phân cách trước Type
9. [TypeMaxCol ] - Độ rộng cho Type

Bản hiện tại:

capture-png.208131


Dự kiến bản tiếp theo:
- In ra Đầu đề Column của vùng tham chiếu

capture-png.208135


Mã:
Sub test_dbPrint()
    Dim arr(), d2(2, 2) As Integer,arr2
    Dim i As Integer, j As Integer, k As Integer
   ReDim arr( 1 to 5, 1 to 5 )
    For i = 1 To 5
        For j = 1 To 5

            arr(i, j) = "ABCDE"
        Next j
    Next
    arr2 = Array(1.7, 2, "3", , 5, True, vbNewLine, 10000000, 1 / 2)
    dbPrint arr, True, , True, , 7
    dbPrint arr2, True, , True, , 7

End Sub

Function dbPrint(Optional ByVal im, _
                     Optional arrayHeader As Boolean = False, _
                     Optional punc As String = "", _
                     Optional reTypeArray2D As Boolean = False, _
                     Optional widthMinCol As Integer = 6, _
                     Optional widthMaxCol As Integer = 25, _
                     Optional puncMain As String = " ", _
                     Optional puncType As String = ".", _
                     Optional typeMaxCol As Integer = 10)
        viewImmediate
        If caption Then arrayHeader = False
        If widthMinCol >= widthMaxCol Then Debug.Print "Set: widthMinCol < widthMaxCol": Exit Function
        If IsMissing(im) Then Debug.Print "<Missing>": Exit Function
        Dim cell As Variant, ubIM As Long, i As Long: i = 0:
        Dim m As Integer, mHeader As String, nHeader As String, n As Integer, jString As String, reTypeStr As String
        Dim topPrint As Boolean, strPrint As String, strBorder As String: topPrint = False
        Dim lArr() As Variant, puncW As String, puncH As String, overCol As Boolean: overCol = False
        puncW = " |": puncH = "|"
        If IsArray(im) Then
            If IsObject(im) Then
                     'Update sau
            End If
            Debug.Print VBA.String(1, vbNewLine)
            If bool_array2d(im) Then
                Dim imLBound As Long, imUBound As Long, imLBound2 As Long, imUBound2 As Long
                imLBound = LBound(im): imLBound2 = LBound(im, 2): imUBound = UBound(im): imUBound2 = UBound(im, 2)
                ReDim lArr(imLBound2 To imUBound2)
                For n = imLBound2 To imUBound2
                    lArr(n) = widthMinCol
                Next n
                For m = imLBound To imUBound
                    For n = imLBound2 To imUBound2
                        If Len(im(m, n)) > lArr(n) Then lArr(n) = Len(im(m, n))
                        If lArr(n) > widthMaxCol Then lArr(n) = widthMaxCol
                    Next n
                Next m

                For m = imLBound To imUBound
                    If punc = vbNullString Then
                        mHeader = addCharStrL(m + arrayHeader, " ", "", "|", 3)
                        nHeader = addCharStrL(, " ", "", "+", 3)
                        If m = imLBound And arrayHeader Then mHeader = addCharStrL(, " ", "", "|", 3): _
                                             nHeader = addCharStrL(, " ", "", "+", 3)
                    Else
                        mHeader = addCharStrL(punc, " ", "", "|", 3)
                        If m = imLBound Then nHeader = addCharStrL(punc, " ", "", "+", 3)
                    End If
                    jString = vbNullString
                    For n = imLBound2 To imUBound2
                        widthMaxCol = lArr(n)

                        If reTypeArray2D Then
                            puncW = ""
                            reTypeStr = addCharStrL(reType(im(m, n)), " ", IIf(Len(puncType) = 1, " " & puncType, Left(puncType, 1)), "|", typeMaxCol + 1)
                            If m = 1 And arrayHeader Then
                                reTypeStr = addCharStrL("Type", " ", IIf(Len(puncType) = 1, " " & puncType, Left(puncType, 1)), "|", typeMaxCol + 1)
                            End If
                            If Not topPrint Then
                                   strBorder = strBorder & addCharStrL("", "-", , "+", widthMaxCol + 14)
                            End If
                        Else
                            If Not topPrint Then
                                strBorder = strBorder & addCharStrL("", "-", , "+", widthMaxCol + 2)
                            End If
                        End If
                
                        jString = jString & addCharStrL(im(m, n), puncMain, " ", puncW, widthMaxCol) & reTypeStr
                    Next n
                    If Not topPrint Then
                        Debug.Print addCharStrL("IsArray 2D ", "=", , , Len(strBorder) + 4) & vbNewLine & nHeader & strBorder
                              topPrint = True
                    End If
                    Debug.Print mHeader & jString
                    If Not overCol Then If Len(jString) > 1000 Then overCol = True
                    If m = 1 And arrayHeader Then
                        Debug.Print nHeader & strBorder
                    End If
                 Next m
            Else
                Debug.Print "IsArray 1D ========================================" & vbNewLine & _
                            "---------------------------------------------------"
                On Error Resume Next
                ubIM = UBound(im)
                If err.Number <> 0 Then Debug.Print "Array Empty": Exit Function
                For Each cell In im
                    cell = reStrConstants(cell)
                    If IsObject(cell) Then Debug.Print "Array contains object. Can't print !": Exit Function
                    If IsMissing(cell) Then cell = "<Missing!>"
                    i = i + 1
                    mHeader = i
                    If punc <> "" Then mHeader = punc
                    Debug.Print mHeader & vbTab & addCharStrL(cell, , , , widthMaxCol) & " -> " & reType(cell)

                Next cell
            End If
    
            Debug.Print IIf(strBorder <> vbNullString, nHeader & strBorder, addCharStrL("", "-", , , 51)) & _
                        vbNewLine & addCharStrL("End Print ", "=", , , IIf(Len(strBorder) <> 0, Len(strBorder), 46) + 4)
            If UBound(im) > 200 Or overCol Then: Debug.Print "*Warning: Immediate - limit the results - 200 rows / 1000 columns"
        Else
            Debug.Print vbCr & im & " -> " & reType(im)
        End If
    End Function
Sub test_reType()
    dbPrint reType(1)
End Sub
    Public Function reType(Optional ByVal im) As String
        If IsMissing(im) Then reType = "<Missing>": Exit Function
        If VarType(im) = vbArray Then
            reType = "vbArray"
        ElseIf VarType(im) = vbEmpty Then reType = "vbEmpty"
        ElseIf VarType(im) = vbNull Then reType = "vbNull"
        ElseIf VarType(im) = vbInteger Then reType = "vbInteger"
        ElseIf VarType(im) = vbLong Then reType = "vbLong"
        ElseIf VarType(im) = vbSingle Then reType = "vbSingle"
        ElseIf VarType(im) = vbDouble Then reType = "vbDouble"
        ElseIf VarType(im) = vbCurrency Then reType = "vbCurrency"
        ElseIf VarType(im) = vbDate Then reType = "vbDate"
        ElseIf VarType(im) = vbString Then
            reType = "vbString"
            If vbStrConstants(im) Then reType = "vbStrConstants"
        ElseIf VarType(im) = vbObject Then reType = "vbObject"
        ElseIf VarType(im) = vbError Then reType = "vbError"
        ElseIf VarType(im) = vbBoolean Then reType = "vbBoolean"
        ElseIf VarType(im) = vbVariant Then reType = "vbVariant"
        ElseIf VarType(im) = vbDataObject Then reType = "vbDataObject"
        ElseIf VarType(im) = vbDecimal Then reType = "vbDecimal"
        ElseIf VarType(im) = vbByte Then reType = "vbByte"
        ElseIf VarType(im) = vbUserDefinedType Then reType = "vbUserDefinedType"
        ElseIf VarType(im) = vbLongLong Then reType = "vbLongLong"
        Else
            reType = im
        End If
    End Function
Sub test_vbStrConstants()
    dbPrint vbStrConstants("vbEmpty")
End Sub
    Public Function vbStrConstants(Optional ByVal im As Variant) As Boolean
        If IsMissing(im) Then Exit Function
        If im = vbEmpty Or im = vbCr Or im = vbCrLf _
        Or im = vbFormFeed Or im = vbLf Or im = vbNewLine _
        Or im = vbNullChar Or im = vbNullString Or im = vbTab Or im = vbVerticalTab _
        Or im = "vbEmpty" Or im = "vbCr" Or im = "vbCrLf" _
        Or im = "vbFormFeed" Or im = "vbLf" Or im = "vbNewLine" _
        Or im = "vbNullChar" Or im = "vbNullString" Or im = "vbTab" Or im = "vbVerticalTab" Then _
        vbStrConstants = True
    End Function
Sub test_reStrConstants()
    dbPrint reStrConstants(vbEmpty)
End Sub
    Public Function reStrConstants(Optional ByVal im As Variant) As Variant
        reStrConstants = im
        If IsMissing(im) Then reStrConstants = "<Missing>": Exit Function
        If im = vbEmpty Then reStrConstants = "vbVerticalTab"
        If im = vbCr Then reStrConstants = "vbCr"
        If im = vbCrLf Then reStrConstants = "vbCrLf"
        If im = vbFormFeed Then reStrConstants = "vbFormFeed"
        If im = vbLf Then reStrConstants = "vbLf"
        If im = vbNewLine Then reStrConstants = "vbNewLine"
        If im = vbNullChar Then reStrConstants = "vbNullChar"
        If im = vbNullString Then reStrConstants = "vbNullString"
        If im = vbTab Then reStrConstants = "vbTab"
        If im = vbVerticalTab Then reStrConstants = "vbVerticalTab"
    End Function
Sub test_addCharStrL()
    Dim em As String
    em = addCharStrL("a", "->", "-", "|", 30, 1)
    Debug.Print em & " len: " & Len(em)
End Sub
    Function addCharStrL(Optional ByVal strL As Variant = "", _
                                Optional ByVal MainChar As Variant = " ", _
                                Optional ByVal charL As Variant = "", _
                                Optional ByVal charR As Variant = "", _
                                Optional ByVal limitStr As Integer = 25, _
                                Optional ByVal loopStr As Long = 1) As String
        Dim i As Integer, j As Integer, char_L As String, char_R As String, reStr As String, Char As String
        Dim lenL As Integer: lenL = Len(strL)
        If lenL > limitStr Then strL = Left(strL, limitStr - 2) & ".."
        Char = newStrChar(MainChar, limitStr - Len(strL), Len(strL))
        reStr = charL & strL & Char & charR
        For i = 1 To loopStr
            addCharStrL = addCharStrL & reStr
        Next
    End Function
Sub test_newStrChar()
    Dim em As String
    em = newStrChar("->", 45, Len("helloa"))
    Debug.Print em & " len: " & Len(em)
End Sub
    Function newStrChar(Optional ByVal strChar As Variant = " ", _
                        Optional ByVal limitChar As Integer, _
                        Optional ByVal LStart As Integer)
        If limitChar <= 0 Then newStrChar = "": Exit Function
        Dim i As Integer, m As Integer, n As Integer, k As Integer, arr() As Variant
        k = Len(strChar): m = 0: n = 0
        ReDim arr(limitChar - 1)
        Do
            For i = 1 To k
                If m >= LStart Then: arr(n) = Mid(strChar, i, 1): n = n + 1
                m = m + 1
                If n = limitChar Then GoTo Result
            Next i
        Loop While True
Result: newStrChar = Join(arr, "")
    End Function
    Function bool_array2d(arr As Variant) As Boolean
        Dim i As Long
        On Error Resume Next
        i = LBound(arr, 2)
        bool_array2d = Err = 0
    End Function
    Sub viewImmediate()
            On Error Resume Next
            Application.VBE.Windows("Immediate").Visible = True
    End Sub
 

CẨM NANG KẾ TOÁN TRƯỞNG


Liên hệ: 090.6969.247

KÊNH YOUTUBE DKT

Kỹ thuật giải trình thanh tra BHXH

Đăng ký kênh nhé cả nhà

SÁCH QUYẾT TOÁN THUẾ


Liên hệ: 090.6969.247

Top