应用程序 VBA / 将数据传输到工作表
此页面概述了将数据从 VBA 传输到工作表的过程。代码模块包含将一维和二维数组传输到工作表的程序。单行和块传输也包含简短的代码行注释。.
- 如果保持模块完整，效果最佳。顶部的过程包含运行其他过程的代码行。只需取消对要运行的代码行的注释，并为不打算运行的行添加注释标记。
- 代码过程包括来自二维数组的正常或转置传输。.
- 此外，还包含了一维数组的处理。它们可以传输到列或行中。
- 在每种情况下都可以指定放置位置。.
- 注意，每次运行时都会清除所选工作表，因此选择一个用于输出的工作表，该工作表不会删除必要的数据。
- ConvColAlphaToNum() 和 ConvColNumToAlpha() 已包含在内，用于在字母和数字格式之间转换工作表列引用。
- 添加了用于清除和格式化文本以及工作表的附加过程。
Option Explicit
Sub TestArraysToSheet()
'test proc for transfers to the sheet
'de-comment lines to test the code
Dim vDim1 As Variant, vDim2 As Variant, vTemp As Variant, vR
Dim oSht As Worksheet, r As Long, c As Long, rTarget As Range
Dim Rng as range
' set choice of worksheet
Set oSht = ActiveWorkbook.Worksheets("Sheet2")
set rng=osht.cells(1,1)
' clear existing contents of worksheet
oSht.Activate
oSht.Cells.ClearContents
' load 1D test array
vDim1 = Array(9, 8, 7, 5, 6, 4, 3, 2, 1, 0) 'or,
'vDim1 = Array("Horses", "Dogs", "Zebras", "Fleas") 'or,
'vDim1 = Split("A B C D E F G H I J K L M N O P Q R S T U V W X Y Z", " ") 'zero based
' load 2D test array
ReDim vDim2(1 To 20, 1 To 10)
For r = 1 To 20
For c = 1 To 10
vDim2(r, c) = (r * c)
Next c
Next r
' CLEARING THE SHEET
'-------------------
oSht.Cells.ClearContents ' clears sheet text entries only
'oSht.Cells.ClearFormats ' clears sheet formats only
'oSht.Cells.Clear ' clears everthing on sheet
'oSht.Range("A1:G37").ClearContents 'clears entries from cell block
'oSht.Range(oSht.Cells(1, 1), oSht.Cells(1, 9)).ClearContents 'clears entries from cell block
'ClearRange rng, "contents" 'clears cell range according to option
'ClearWorksheet("Sheet2", 1 ) 'clears all sheet2 cell contents only
' REMOVE ALL WORKBOOK CHARTS
'---------------------------
'DeleteAllWorkbookCharts 'clears all charts from the workbook - not just those on top sheet
'' TRANSFER SINGLE VALUES TO SHEET
'--------------------------------
'oSht.Cells(3, 7).Value = "Totals" 'string to one specified cell
'oSht.Range("A1").Value = "Totals" 'string to one specified cell
' TRANSFER ONE VALUE TO A SHEET BLOCK
'------------------------------------
'oSht.Range(oSht.Cells(1, 1), oSht.Cells(10, 7)).Value = "N/A"
'oSht.Range("A1:F10").Value = "N/A"
'TRANSFER 1 DIMENSION LIST ARRAYS TO WORKSHEET
'---------------------------------------------
Array1DToSheetRow vDim1, "Sheet2", 3, 7 ' 1D array to sheet row, start position (3,7)
'Array1DToSheetCol vDim1, "Sheet2", 3, 7 ' 1D array to sheet column, start position (3,7)
'TRANSFER 2 DIMENSIONAL ARRAYS TO WORKSHEET
'------------------------------------------
'Array2DToSheet vDim2, "Sheet2", 2, 2 ' 2D array to sheet, start position (2,2)
'Arr1Dor2DtoWorksheet vDim2,"Sheet2",4,5 ' 1D or 2D array to worksheet; 2D here.
'TransArray2DToSheet vDim2, "Sheet2", 2, 2 ' TRANSPOSED 2D array to sheet, start position (2,2)
'TransposeArray2D vDim2, vTemp ' alternative method of TRANSPOSED 2D array to sheet
'Array2DToSheet vTemp,"Sheet2" , 1, 1
'FORMAT WORKSHEET CELLS AFTER TRANSFER
'------------------------------------------
'FormatCells "Sheet2" 'applies one of several formats to all cells of the worksheet
'FormatRange Rng, "bold" 'applies one of several formats to the specified cell range
End Sub
Sub Array1DToSheetCol(ByVal vIn As Variant, sShtName As String, nStartRow As Long, nStartCol As Long)
' transfers contents of single dimension list array to specified position in worksheet
' Works for any array bounds
Dim oSht As Worksheet, rTarget As Range
Dim nElem As Long
Dim nNewC As Long, nNewR As Long
' get reference to sheet for output
Set oSht = ActiveWorkbook.Worksheets(sShtName)
' get the pre-shift end points
nElem = UBound(vIn, 1) - LBound(vIn, 1) + 1
' define the sheet range for the array contents
Set rTarget = oSht.Range(oSht.Cells(nStartRow, nStartCol), oSht.Cells(nStartRow + nElem - 1, nStartCol))
'transfer the array contents to the sheet range
rTarget.Value = Application.WorksheetFunction.Transpose(vIn)
End Sub
Sub Array1DToSheetRow(ByVal vIn As Variant, sShtName As String, nStartRow As Long, nStartCol As Long)
' transfers contents of single dimension list array into a worksheet column
' The cell for the first element is set by nStartRow and nStartCol
' Works for any array bounds
Dim oSht As Worksheet, rTarget As Range
Dim nElem As Long
Dim nNewC As Long, nNewR As Long
' get reference to sheet for output
Set oSht = ActiveWorkbook.Worksheets(sShtName)
' get the pre-shift end points
nElem = UBound(vIn, 1) - LBound(vIn, 1) + 1
' define the sheet range for the array contents
Set rTarget = oSht.Range(oSht.Cells(nStartRow, nStartCol), oSht.Cells(nStartRow, nStartCol + nElem - 1))
'transfer the array contents to the sheet range
rTarget.Value = vIn
End Sub
Sub TransArray2DToSheet(ByVal vIn As Variant, sShtName As String, nStartRow As Long, nStartCol As Long)
' transfers contents of input 2D array to specified worksheet positions TRANSPOSED
' The cell for the first element is set by nStartRow and nStartCol
' Works for any array bounds
Dim oSht As Worksheet, rTarget As Range
Dim nRows As Long, nCols As Long
Dim nNewEndC As Long, nNewEndR As Long
'get reference to sheet for output
Set oSht = ActiveWorkbook.Worksheets(sShtName)
'get the pre-shift end points
nRows = UBound(vIn, 1) - LBound(vIn, 1) + 1
nCols = UBound(vIn, 2) - LBound(vIn, 2) + 1
'swap cols and rows
nNewEndR = nCols + nStartRow - 1
nNewEndC = nRows + nStartCol - 1
' define the transposed range for the array contents
Set rTarget = oSht.Range(oSht.Cells(nStartRow, nStartCol), oSht.Cells(nNewEndR, nNewEndC))
'transfer the array contents to the sheet range
rTarget.Value = Application.WorksheetFunction.Transpose(vIn)
End Sub
Sub Array2DToSheet(ByVal vIn As Variant, sShtName As String, nStartRow As Long, nStartCol As Long)
' transfers contents of input 2D array to specified worksheet positions
' Works for any array bounds
Dim oSht As Worksheet, rTarget As Range
Dim nRows As Long, nCols As Long
Dim nNewEndC As Long, nNewEndR As Long
'get reference to sheet for output
Set oSht = ActiveWorkbook.Worksheets(sShtName)
'get the pre-shift end points
nRows = UBound(vIn, 1) - LBound(vIn, 1) + 1
nCols = UBound(vIn, 2) - LBound(vIn, 2) + 1
'modify end point for parameter starting values
nNewEndR = nRows + nStartRow - 1
nNewEndC = nCols + nStartCol - 1
' define the sheet range for the array contents
Set rTarget = oSht.Range(oSht.Cells(nStartRow, nStartCol), oSht.Cells(nNewEndR, nNewEndC))
'transfer the array contents to the sheet range
rTarget.Value = vIn
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
Function TransposeArray2D(vA As Variant, Optional vR As Variant) As Boolean
'---------------------------------------------------------------------------------
' Procedure : Transpose2DArr
' Purpose : Transposes a 2D array; rows become columns, columns become rows
' Specifically, (r,c) is moved to (c,r) in every case.
' Options include, returned in-place with the source changed, or
' if vR is supplied, returned in that instead, with the source intact.
'---------------------------------------------------------------------------------
Dim vW As Variant
Dim loR As Long, hiR As Long, loC As Long, hiC As Long
Dim r As Long, c As Long, bWasMissing As Boolean
'find whether optional vR was initially missing
bWasMissing = IsMissing(vR)
If Not bWasMissing Then Set vR = Nothing
'use a work array
vW = vA
'find bounds of vW data input work array
loR = LBound(vW, 1): hiR = UBound(vW, 1)
loC = LBound(vW, 2): hiC = UBound(vW, 2)
'set vR dimensions transposed
'Erase vR 'there must be an array in the variant to erase
ReDim vR(loC To hiC, loR To hiR)
'transfer data
For r = loR To hiR
For c = loC To hiC
'transpose vW into vR
vR(c, r) = vW(r, c)
Next c
Next r
'find bounds of vW data input work array
' loR = LBound(vR, 1): hiR = UBound(vR, 2)
' loC = LBound(vR, 2): hiC = UBound(vR, 2)
TRANSFERS:
'decide whether to return in vA or vR
If Not bWasMissing Then
'vR was the intended return array
'so leave vR as it is
Else:
'vR is not intended return array
'so reload vA with vR
vA = vR
End If
'return success for function
TransposeArray2D = True
End Function
Sub testCellRefConversion()
'run this to cell reference conversions
Dim nNum As Long, sLet As String
'set input values here
nNum = 839
sLet = "AFG"
MsgBox ConvColAlphaToNum(sLet)
MsgBox ConvColNumToAlpha(nNum)
End Sub
Function ConvColAlphaToNum(ByVal sColAlpha As String) As Long
'Converts an Excel column reference from alpha to numeric
'For example, "A" to 1, "AFG" to 839 etc
Dim nColNum As Long
'get the column number
nColNum = Range(sColAlpha & 1).Column
'output to function
ConvColAlphaToNum = nColNum
End Function
Function ConvColNumToAlpha(ByVal nColNum As Long) As String
'Converts an Excel column reference from numeric to alpha
'For example, 1 to "A", 839 to "AFG" etc
Dim sColAlpha As String, vA As Variant
'get the column alpha, in form $D$14
sColAlpha = Cells(1, nColNum).Address
'split the alpha reference on $
vA = Split(sColAlpha, "$")
'output second element (1) of array to function
ConvColNumToAlpha = vA(1) 'array is zero based
End Function
Sub DeleteAllWorkbookCharts()
'run this manually to delete all charts
'not at this stage called in any procedure
Dim oC
Application.DisplayAlerts = False
For Each oC In ThisWorkbook.Charts
oC.Delete
Next oC
Application.DisplayAlerts = True
End Sub
Sub FormatCells(sSht As String)
' Applies certain formats to all cells
' of the named parameter sheet
Dim oSht As Worksheet
Set oSht = ThisWorkbook.Worksheets(sSht)
oSht.Activate
'format all cells of the worksheet
oSht.Cells.Select
With Selection
.Font.Name = "Consolas"
.Font.Size = 20
.Columns.AutoFit
.Rows.AutoFit
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlBottom
End With
oSht.Range("A1").Select
End Sub
Sub testFormatRange()
'place some text in cell 1,1 of sheet1
Dim oSht As Worksheet, Rng As Range
Set oSht = ThisWorkbook.Worksheets("Sheet1")
Set Rng = oSht.Cells(1, 1)
FormatRange Rng, "autocols"
Rng.Select
Set Rng = Nothing
End Sub
Sub FormatRange(ByRef rRange As Range, ByVal sOpt As String)
' Applies certain formats to
' the parameter range of cells
' in accordance with selected option
With rRange
Select Case LCase(sOpt)
Case "consolas" 'make monospaced
.Font.Name = "Consolas"
Case "calibri" 'make non-mono
.Font.Name = "Calibri"
Case "autocols" 'autofit column width
.Columns.AutoFit
Case "noautocols" 'default column width
.ColumnWidth = 8.43
Case "hcenter" 'center text horizontally
.HorizontalAlignment = xlCenter
Case "hleft" 'left text horizontally
.HorizontalAlignment = xlLeft
Case "bold" 'bold text
.Font.Bold = True
Case "nobold" 'normal weight text
.Font.Bold = False
Case "italic" 'italic text
.Font.Italic = True
Case "noitalic" 'non-italic text
.Font.Italic = False
Case "underline" 'underlined text
.Font.Underline = xlUnderlineStyleSingle
Case "nounderline" 'non-underlined text
.Font.Underline = xlUnderlineStyleNone
Case Else
End Select
End With
End Sub
Sub testClearWorksheet()
'run this to test worksheet clearing
If SheetExists("Sheet1") Then
ClearWorksheet "Sheet11", 3
Else 'do other stuff
End If
End Sub
Function ClearWorksheet(ByVal sSheet As String, ByVal nOpt As Integer) As Boolean
'clears worksheet contents, formats, or both
'nOpt options: contents=1, formats=2, all=3
Dim oWSht As Worksheet
Set oWSht = ThisWorkbook.Worksheets(sSheet)
oWSht.Activate
With oWSht.Cells
Select Case nOpt
Case 1 'contents only
.ClearContents
Case 2 'formats only
.ClearFormats
Case 3 'formats and contents
.Clear
Case Else
MsgBox "Illegal option in ClearWorksheet - closing"
Exit Function
End Select
End With
oWSht.Cells(1, 1).Select
ClearWorksheet = True
End Function
Sub testClearRange()
'place some text in cell 1,1 of sheet1
Dim oSht As Worksheet, Rng As Range
Set oSht = ThisWorkbook.Worksheets("Sheet1")
Set Rng = oSht.Cells(1, 1)
ClearRange Rng, "all"
Rng.Select
Set Rng = Nothing
End Sub
Sub ClearRange(ByRef rRng As Range, Optional ByVal sOpt As String = "contents")
'clears cell range contents, formats, or both
'sOpt options: "contents", "formats", or "all"
'sOpt is optional, default "contents".
With rRng
Select Case LCase(sOpt)
Case "contents" 'contents only
.ClearContents
Case "formats" 'formats only
.ClearFormats
Case "all" 'formats and contents
.Clear
Case Else
MsgBox "Illegal option in ClearRange - closing"
Exit Sub
End Select
End With
End Sub