Visual Basic for Applications/陣列輸出傳輸
此 VBA 程式碼模組演示了四種基本的陣列顯示方法。它旨在在 MS Excel 中執行，儘管除了第一種方法（將資料傳輸到工作表）之外，它可以很容易地適應 MS Word 或其他執行 VBA 的 MS Office 應用程式。
- 程式碼首先使用選定的隨機資料載入一個數組。然後，整個陣列被傳輸到工作表。資料在立即視窗中被進一步格式化和顯示，以良好的間距列顯示。格式化輸出的另外一個副本被傳遞到剪貼簿以供進一步的外部使用，並且它也被髮送到一個文字檔案以說明該方法。
- RndDataToArr() 可以使用隨機資料載入一個數組。資料型別可以作為引數設定，並且可以在過程本身內找到進一步的限制。字母、整數、小數、日期和混合資料是可用的，大多數在長度和內容上都是隨機的。
- Arr1Dor2DtoWorksheet() 可以將一維或二維陣列傳輸到工作表。它可以定位在任何位置。它檢查陣列是否存在，是否已分配，以及在設定傳輸範圍時的維度數量。
- DispArrInImmWindow() 在 VBA 編輯器的立即視窗中格式化並顯示一個 2D 陣列。它考慮了所有資料長度以設定對齊良好的列。有一些引數可以設定最大小數位數以及選擇小數點對齊還是原始資料。佈局可以處理文字和數字的混合列，儘管當列中的所有資料都是同一型別時，它具有最佳外觀。整個陣列的格式化輸出作為單個字串提供，以便外部使用，對於超過 199 行的陣列非常有用，因為太大而無法顯示在立即視窗中。
- CopyToClip() 用於將字串傳遞到剪貼簿。這裡使用它來上傳格式化的陣列字串。剪貼簿只會在呼叫應用程式（Excel）關閉時保留其內容。值得注意的是，此係列中的其他剪貼簿過程會保留其內容，直到 Windows 平臺關閉。
- GetFromClip() 檢索剪貼簿的內容。它在這裡純粹用於演示。它將陣列的整個格式化字串傳遞給一個文字檔案。
- WriteToFile() 開啟並寫入一個命名的文字檔案。它完全替換它已經包含的任何文字。如果檔案不存在，該過程會在與 Excel 檔案相同的目錄中建立它。
將整個程式碼清單複製到一個 Excel VBA 模組中，並執行頂部過程以測試四種陣列傳輸方法。將檔案儲存為 xlsm 型別。程式碼寫入 Sheet1，以及 VBA 編輯器的立即視窗。其他陣列列表將在剪貼簿和一個專門為該目的建立的文字檔案中找到。
Option Explicit
Private Sub ArrayOutputTests()
' Test procedure for array display
'1 array to worksheet
'2 formatted array to immediate window
'3 formatted array to clipboard
'4 formatted array to text file
Dim vA As Variant, vB As Variant
Dim sArr As String, oSht As Worksheet
Dim sIn As String, sOut As String, sSheet As String
'-------------------------------------------
'choose worksheet for display
'-------------------------------------------
sSheet = "Sheet1"
Set oSht = ThisWorkbook.Worksheets(sSheet)
'-------------------------------------------
'load an array to test
'-------------------------------------------
RndDataToArr vA, 16, 10, "mixed"
vB = vA
'-------------------------------------------
'array to the worksheet
'-------------------------------------------
'clear the worksheet
oSht.Cells.Clear
'transfer array
Arr1Dor2DtoWorksheet vA, "Sheet1", 1, 1
'format columns of the sheet
With oSht.Cells
.Columns.AutoFit
.NumberFormat = "General"
.NumberFormat = "0.000" 'two decimals
End With
'-------------------------------------------
'array formatted and to the immediate window
'-------------------------------------------
'clear the immediate window
ClearImmWindow
'formatted array to immediate window
DispArrInImmWindow vB, True, 3, sIn
'get formatted array string for further use
sArr = sIn
'--------------------------------------------
'array formatted and to the clipboard
'--------------------------------------------
'formatted array string to clipboard
CopyToClip sArr
'--------------------------------------------
'array formatted and to a text file or log
'--------------------------------------------
'retrieve clipboard string
sOut = GetFromClip
'formatted array string replaces text file content
WriteToFile sOut, ThisWorkbook.Path & "\MyLongArray.txt"
'---------------------------------------------
'release object variables
'---------------------------------------------
Set oSht = Nothing
End Sub
Private Sub RndDataToArr(vIn As Variant, nRows As Integer, nCols As Integer, sType As String)
'Loads a 2D array in place with a choice of random alpha strings
'numbers or dates.
Dim LB1 As Long, UB1 As Long, LB2 As Long, UB2 As Long
Dim nMinLenStr As Integer, nMaxLenStr As Integer
Dim nMinLenDec As Integer, nMaxLenDec As Integer
Dim nMinLenInt As Integer, nMaxLenInt As Integer
Dim LA As Integer, LI As Integer, sT As String, sT2 As String
Dim sAccum As String, sAccum1 As String, sAccum2 As String
Dim nDec As Single, LD As Integer, nS As Integer, sDF As String
Dim sAlpha As String, sInteger As String, sDecimal As String
Dim r As Long, c As Long, bIncMinus As String, bNeg As Boolean
Dim dMinDate As Date, dMaxDate As Date, nD As Long
'------------------------------------------------------------------------
'Parameter Notes:
'sType sets the type of data to load into the array.
' "Alpha" loads random length strings of capitals - length set below
' "Integer" loads random length integers - length set below
' "Decimal" loads random integer and decimal parts - length set below
' "Dates" loads random dates throughout - range set below
' "Mixed" loads alternate columns of alpha and decimal data - set below
'nRows is the number of required array rows
'nCols is the number of required array columns
'vIn contains the input array
'------------------------------------------------------------------------
ReDim vIn(1 To nRows, 1 To nCols)
LB1 = LBound(vIn, 1): UB1 = UBound(vIn, 1)
LB2 = LBound(vIn, 2): UB2 = UBound(vIn, 2)
'--------------------------------------------------
'set user minimum and maximum settings here
nMinLenStr = 3 'the minimum random text length
nMaxLenStr = 8 'the maximum random text length
nMinLenDec = 1 'the minumum decimal part length
nMaxLenDec = 3 'the maximum decimal part length
nMinLenInt = 1 'the minimum integer part length
nMaxLenInt = 5 'the maximum integer part length
dMinDate = #1/1/1900# 'earliest date to list
dMaxDate = Date 'latest date to list
sDF = "dddd, mmm d yyyy" 'random date format
bIncMinus = True 'include random minus signs
'--------------------------------------------------
'randomize using system timer
Randomize
For r = LB1 To UB1
For c = LB2 To UB2
'get random lengths of elements
Select Case LCase(sType)
Case "alpha"
LA = Int((nMaxLenStr - nMinLenStr + 1) * Rnd + nMinLenStr)
Case "integer"
LI = Int((nMaxLenInt - nMinLenInt + 1) * Rnd + nMinLenInt)
Case "decimal"
LI = Int((nMaxLenInt - nMinLenInt + 1) * Rnd + nMinLenInt)
LD = Int((nMaxLenDec - nMinLenDec + 1) * Rnd + nMinLenDec)
Case "mixed"
LA = Int((nMaxLenStr - nMinLenStr + 1) * Rnd + nMinLenStr)
LI = Int((nMaxLenInt - nMinLenInt + 1) * Rnd + nMinLenInt)
LD = Int((nMaxLenDec - nMinLenDec + 1) * Rnd + nMinLenDec)
Case "dates"
End Select
'make an alpha string
Do
sT = Chr$(Int((90 - 65 + 1) * Rnd + 65))
sAccum = sAccum & sT
Loop Until Len(sAccum) >= LA
sAlpha = sAccum
sAccum = "": sT = ""
'make an integer
Do
If LI = 1 Then 'zero permitted
sT = Chr$(Int((57 - 48 + 1) * Rnd + 48))
sAccum = sAccum & sT
ElseIf LI > 1 And Len(sAccum) = 0 Then 'zero not permitted
sT = Chr$(Int((57 - 49 + 1) * Rnd + 49))
sAccum = sAccum & sT
Else
sT = Chr$(Int((57 - 48 + 1) * Rnd + 48))
sAccum = sAccum & sT
End If
Loop Until Len(sAccum) >= LI
sInteger = sAccum
sAccum = "": sT = ""
'make a decimal part
Do
sT2 = Chr$(Int((57 - 48 + 1) * Rnd + 48))
sAccum2 = sAccum2 & sT2
Loop Until Len(sAccum2) >= LD
sDecimal = sAccum2
sAccum = "": sAccum2 = "": sT2 = ""
'decide proportion of negative numbers
nS = Int((3 - 0 + 1) * Rnd + 0)
If nS = 1 And bIncMinus = True Then
sInteger = "-" & sInteger
End If
'assign value to array element
Select Case LCase(sType)
Case "alpha"
vIn(r, c) = sAlpha
Case "integer"
vIn(r, c) = CLng(sInteger)
Case "decimal"
vIn(r, c) = CSng(sInteger & "." & sDecimal)
Case "dates"
nD = WorksheetFunction.RandBetween(dMinDate, dMaxDate)
vIn(r, c) = Format(nD, sDF)
Case "mixed"
If c Mod 2 = 0 Then 'alternate columns alpha and decimal
vIn(r, c) = CSng(sInteger & "." & sDecimal)
Else
vIn(r, c) = sAlpha
End If
End Select
Next c
Next r
End Sub
Private Function Arr1Dor2DtoWorksheet(vA As Variant, ByVal sSht As String, _
ByVal nRow As Long, ByVal nCol As Long) As Boolean
'Transfers a one or two dimensioned input array vA to the worksheet,
'with top-left element at cell position nRow,nCol. sSht is the worksheet name.
'Default 2D array transfers are made unchanged and a 1D array is displayed in a row.
Dim oSht As Worksheet, rng As Range, rng1 As Range, bProb As Boolean
Dim nD As Integer, nR As Integer, nDim As Integer, r As Long, c As Long
Dim LBR As Long, UBR As Long, LBC As Long, UBC As Long, vT As Variant
'CHECK THE INPUT ARRAY
On Error Resume Next
'is it an array
If IsArray(vA) = False Then
bProb = True
End If
'check if allocated
nR = UBound(vA, 1)
If Err.Number <> 0 Then
bProb = True
End If
Err.Clear
If bProb = False Then
'count dimensions
On Error Resume Next
Do
nD = nD + 1
nR = UBound(vA, nD)
Loop Until Err.Number <> 0
Else
MsgBox "Parameter is not an array" & _
vbCrLf & "or is unallocated - closing."
Exit Function
End If
'get number of dimensions
Err.Clear
nDim = nD - 1: 'MsgBox nDim
'get ref to worksheet
Set oSht = ThisWorkbook.Worksheets(sSht)
'set a worksheet range for array
Select Case nDim
Case 1 'one dimensional array
LBR = LBound(vA): UBR = UBound(vA)
Set rng = oSht.Range(oSht.Cells(nRow, nCol), oSht.Cells(nRow, nCol + UBR - LBR))
Case 2 'two dimensional array
LBR = LBound(vA, 1): UBR = UBound(vA, 1)
LBC = LBound(vA, 2): UBC = UBound(vA, 2)
Set rng = oSht.Range(oSht.Cells(nRow, nCol), oSht.Cells(nRow + UBR - LBR, nCol + UBC - LBC))
Case Else 'unable to print more dimensions
MsgBox "Too many dimensions - closing"
Exit Function
End Select
'transfer array values to worksheet
rng.Value = vA
'release object variables
Set oSht = Nothing
Set rng = Nothing
'returns
Arr1Dor2DtoWorksheet = True
End Function
Private Sub ClearImmWindow()
'NOTES
'Clears VBA immediate window down to the insertion point,
'but not beyond. Not a problem as long as cursor is
'at end of text, but otherwise not.
'Clear manually before any neat work.
'Manual clear method: Ctrl-G then Ctrl-A then Delete.
'Max display in immediate window is 199 lines,
'then top lines are lost as new ones added at bottom.
'No reliable code method exists.
Debug.Print String(200, vbCrLf)
End Sub
Private Sub DispArrInImmWindow(vA As Variant, Optional ByVal bFormatAlignData = True, _
Optional ByVal nNumDecs As Integer = 2, _
Optional sOut As String)
'--------------------------------------------------------------------------
'vA : Input 2D array for display in the immediate window.
'sOut: Alternative formatted output string.
'bFormatAlignData : True: applies decimal rounding and decimal alignment,
' False: data untouched with only basic column spacing.
'nNumDecs: Sets the rounding up and down of decimal places.
' Integers do not have zeros added at any time.
'Clear the immediate window before each run for best results.
'The immediate window at best lists 199 lines before overwrite, so
'consider using sOut for large arrays. 'ie; use it in a text file
'or userform textbox. Both outputs depend on the use of MONOSPACED fonts,
'so set the font VBA editor or any textbox to Courier or Consolas.
'To set different formats for EVERY column of an array it is best to add
'the formats at loading time with the procedure TabularAlignTxtOrNumber().
'--------------------------------------------------------------------------
'messy when integers are set in array and decimals is set say to 3.
'maybe the measurement of max element width should include a measure
' for any dot or extra imposed decimal places as well
'different for integers and for existing decimals
Dim vD As Variant, vC As Variant, nInterFieldSpace As Integer
Dim sPadding As String, sDecFormat As String, sR As String, sE As String
Dim r As Integer, c As Integer, m As Integer, n As Integer, nP As Integer
Dim nMaxFieldWidth As Integer, bSkip As Boolean
Dim LB1 As Long, UB1 As Long, LB2 As Long, UB2 As Long
'get bounds of input array
LB1 = LBound(vA, 1): UB1 = UBound(vA, 1)
LB2 = LBound(vA, 2): UB2 = UBound(vA, 2)
ReDim vD(LB1 To UB1, LB2 To UB2) 'display
ReDim vC(LB2 To UB2) 'column max
'--------------------------------------
'set distance between fixed width
'fields in the output display
nInterFieldSpace = 3
'not now used
nMaxFieldWidth = 14
'--------------------------------------
If nNumDecs < 0 Then
MsgBox "nNumDecs parameter must not be negative - closing"
Exit Sub
End If
'find widest element in each column
'and adjust it for any imposed decimal places
For c = LB2 To UB2
n = 0: m = 0
For r = LB1 To UB1
'get element length
If IsNumeric(vA(r, c)) Then
If Int(vA(r, c)) = vA(r, c) Then 'is integer
n = Len(vA(r, c)) + 1 + nNumDecs
Else 'is not integer
If Len(vA(r, c)) - Len(Int(vA(r, c))) - 1 >= nNumDecs Then 'no change
n = Len(vA(r, c))
Else 'add the difference in length as result of imposed decimal places
n = Len(vA(r, c)) + (nNumDecs - (Len(vA(r, c)) - Len(Int(vA(r, c))) - 1))
End If
End If
Else
n = Len(vA(r, c))
End If
If n > m Then m = n 'update if longer
Next r
'store the maximum length
'of data in each column
vC(c) = m
Next c
For c = LB2 To UB2
For r = LB1 To UB1
sE = Trim(vA(r, c))
If bFormatAlignData = False Then
sDecFormat = sE
nP = InStr(sE, ".")
bSkip = True
End If
'make a basic format
If bSkip = False Then
nP = InStr(sE, ".")
'numeric with a decimal point
If IsNumeric(sE) = True And nP > 0 Then
sDecFormat = Format$(sE, "0." & String$(nNumDecs, "0"))
'integer
ElseIf IsNumeric(sE) = True And nP <= 0 Then
sDecFormat = Format$(sE, "0") & String$(nNumDecs + 1, Chr(32))
'alpha
ElseIf IsNumeric(sE) = False Then
sDecFormat = sE
End If
End If
'adjust field width to widest in column
bSkip = False
sPadding = Space$(vC(c))
'numeric with a decimal point
If IsNumeric(sE) = True And nP > 0 Then
vD(r, c) = Right$(sPadding & sDecFormat, vC(c))
'integer
ElseIf IsNumeric(sE) = True And nP <= 0 Then
vD(r, c) = Right$(sPadding & sDecFormat, vC(c))
'alpha
ElseIf IsNumeric(sE) = False Then
vD(r, c) = Left$(sDecFormat & sPadding, vC(c))
End If
Next r
Next c
'output
sOut = ""
For r = LB1 To UB1
For c = LB2 To UB2
sR = sR & vD(r, c) & Space(nInterFieldSpace) 'concat one row
Next c
Debug.Print sR 'print one row in imm window
sOut = sOut & sR & vbCrLf 'accum one row in output string
sR = ""
Next r
sOut = sOut & vbCrLf
Debug.Print vbCrLf
End Sub
Private Function CopyToClip(sIn As String) As Boolean
'passes the parameter string to the clipboard
'set reference to Microsoft Forms 2.0 Object Library.
'Clipboard cleared when launch application closes.
Dim DataOut As DataObject
Set DataOut = New DataObject
'first pass textbox text to dataobject
DataOut.SetText sIn
'then pass dataobject text to clipboard
DataOut.PutInClipboard
'release object variable
Set DataOut = Nothing
CopyToClip = True
End Function
Private Function GetFromClip() As String
'passes clipboard text to function name
'If clipboard not text, an error results
'set reference to Microsoft Forms 2.0 Object Library.
'Clipboard cleared when launch application closes.
Dim DataIn As DataObject
Set DataIn = New DataObject
'clipboard text to dataobject
DataIn.GetFromClipboard
'dataobject text to function string
GetFromClip = DataIn.GetText
'release object variable
Set DataIn = Nothing
End Function
Private Function WriteToFile(sIn As String, sPath As String) As Boolean
'REPLACES all content of text file with parameter string
'makes file if does not exist
'no layout or formatting - assumes external
Dim Number As Integer
Number = FreeFile 'Get a file number
'write string to file
Open sPath For Output As #Number
Print #Number, sIn
Close #Number
WriteToFile = True
End Function