时间戳

首页 > 解决方案 > 在子例程之间传递动态数组

excel - 在子例程之间传递动态数组

问题描述

我试图在不同的子例程之间传递一个动态数组 DArrayRight()，从 DefineArrayRight （将创建 Array ）到 CellRightMarked （将对工作表执行操作）。不幸的是我试过没有成功。有什么建议么？

非常感谢

Sub DefineArrayRight()
Dim DArrayRight() As Variant ' dynamic array
Dim xrow As Long, i As Long
i = 0
xrow = 2

ReDim DArrayRight(0) ' resize the array to hold 1 string

 Do Until ThisWorkbook.Sheets("Sheet1").Cells(xrow, 2).Value = ""
  If ThisWorkbook.Sheets("Sheet1").Cells(xrow, 3).Value = "Right" Then
    DArrayRight(i) = ThisWorkbook.Sheets("Sheet1").Cells(xrow, 2).Value 'add the value in the array
    i = i + 1 ' increase the upper bound of the array
    ReDim Preserve DArrayRight(i) ' preserve the array
  End If
  xrow = xrow + 1
 Loop
ReDim Preserve DArrayRight(i - 1) ' delete the empty array
End Sub

并传递给这个子例程：

Sub CellRightMarked()
Dim DArrayRight() As Variant
Dim rcell As Range, rrow As Range
Dim r As Integer, i As Long

 For Each sht In ActiveWorkbook.Worksheets
   With sht
     Set rrow = .UsedRange
       For r = LBound(DArrayRight) To UBound(DArrayRight)
        For Each rcell In rrow
            If rcell.Value = DArrayRight(r) Then
                .Range(rcell.Offset(0, 1), rcell.Offset(0, 1)).Font.Color = 255
            End If
        Next rcell
     Next r
   End With
  Next sht
 End Sub

标签： excelvba

解决方案

VBA 为您想要对 sub 执行的操作提供了 Function。这是您需要的功能。它基于您的子，评论改进建议。

Function ArrayRight() As Variant

    Dim Fun() As Variant                    ' function return value
    Dim Ws As Worksheet                     ' easier to refer to
    Dim R As Long, Rl As Long               ' row, last row
    Dim i As Long

    ' i = 0                                 ' i is already zero
    ' R = 2                                 ' defined in the For .. Next loop
    ' ReDim DArrayRight(0) ' resize the array to hold 1 string
    ' Not a good idea because the array will have to be completely
    ' re-written each time you expand it: very slow!

    Set Ws = ThisWorkbook.Sheets("Sheet1")
    Rl = Ws.Cells(Ws.Rows.Count, "B").End(xlUp).Row     ' find the last used row in column B
    ReDim Fun(Rl)                           ' maximum to be possibly required

    For R = 2 To Rl
        If Ws.Cells(R, 3).Value = "Right" Then
            Fun(i) = Ws.Cells(R, 2).Value   'add the value in the array
            i = i + 1                       ' next empty array element
            ' ReDim Preserve DArrayRight(i) ' no need to re-write the array
        End If
    ' R = R + 1                             ' Next is doing the counting
    ' Loop                                  ' Next is doing the looping

    If i Then                               ' skip if no match was found
        ReDim Preserve Fun(i - 1)           ' delete the unused part of array
        ArrayRight = Fun
    End If
End Function

下面的子显示如何使用该功能。

Sub TryArrayRight()

    Dim Arr As Variant

    ' This is the function call.
    ' simply assign its return value to a variable
    Arr = ArrayRight

    ' now test the return
    If IsEmpty(Arr) Then
        MsgBox "The array is empty"
    Else
        MsgBox "The array has " & UBound(Arr) & " elements."

        ' pass the value to another procedure
        CellRightMarked Arr
    End If
End Sub

这里从函数获得的变量作为参数传递给另一个例程。我注释掉了你的代码，因为我没有检查它。对象是显示变量的传递。

Sub CellRightMarked(DArrayRight As Variant)

'    Dim rcell As Range, rrow As Range
'    Dim R As Integer, i As Long
'
'    For Each sht In ActiveWorkbook.Worksheets
'       With sht
'         Set rrow = .UsedRange
'           For R = LBound(DArrayRight) To UBound(DArrayRight)
'            For Each rcell In rrow
'                If rcell.Value = DArrayRight(R) Then
'                    .Range(rcell.Offset(0, 1), rcell.Offset(0, 1)).Font.Color = 255
'                End If
'            Next rcell
'         Next R
'       End With
'    Next sht
 End Sub

当然，在这种特殊情况下，CellRightMarked按照您自己的建议从内部调用函数会更容易。

推荐阅读