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