VBA 通过 arrays 移动行

Question

我对 VBA 中的 arrays 很陌生，需要一些帮助来完成代码......

如果找到数组第一部分中的值，则目标是从一个数组复制到另一个数组。 这是我到目前为止所拥有的，我已经在我正在努力解决的问题中添加了评论。

Option Explicit

Sub ReadingRange()

Dim ARRAY_Multiwage As Variant
Dim ARRAY_TEMP_Multiwage() As Variant
ARRAY_Multiwage = Sheets("Multiwage").Range("A1").CurrentRegion

Dim a As Long
Dim b As Long
For a = LBound(ARRAY_Multiwage, 1) To UBound(ARRAY_Multiwage, 1)
    If ARRAY_Multiwage(a, 1) = "60021184_2018/36/HE" Then
        'add ARRAY_Multiwage(a, 1) to ARRAY_TEMP_Multiwage
        'Debug print to see that it has been added
    Else:
    End If
 Next a
End Sub

任何帮助将不胜感激

Answer 1

试试这个。 您正在寻找的是ReDim选项，用于在将数据输入最新插槽之前动态扩展数组。

Sub ReadingRange()

    Dim ARRAY_Multiwage As Variant
    Dim ARRAY_TEMP_Multiwage() As String
    ARRAY_Multiwage = Sheets("Sheet2").Range("A1").CurrentRegion

    Dim a As Long
    Dim b As Long

    ' c is the counter that helps array become larger dynamically
    Dim c As Long
    c = 0

    For a = LBound(ARRAY_Multiwage, 1) To UBound(ARRAY_Multiwage, 1)

        If ARRAY_Multiwage(a, 1) = "60021184_2018/36/HE" Then

            ' change the dimension of the array
            ReDim Preserve ARRAY_TEMP_Multiwage(c)
            ' add data to it
            ARRAY_TEMP_Multiwage(c) = ARRAY_Multiwage(a, 1)
            ' print what was added
            Debug.Print ("Ubound is " & UBound(ARRAY_TEMP_Multiwage) & ". Latest item in array is " & ARRAY_TEMP_Multiwage(UBound(ARRAY_TEMP_Multiwage)))
            ' get ready to expand the array
            c = c + 1

        Else:
        End If

     Next a
End Sub

Answer 2

我倾向于在目标数组的循环中使用Long数据类型变量作为计数器，这样每次访问数组时，都可以写入一个新元素。 在过去，我一直倾向于用它可以容纳的最大上限来声明新数组，并在最后调整它的大小，因此下面的示例将遵循这一点。

Option Explicit

Sub ReadingRange()

Dim ARRAY_Multiwage As Variant
Dim ARRAY_TEMP_Multiwage() As Variant
ARRAY_Multiwage = Sheets("Multiwage").Range("A1").CurrentRegion

Dim a As Long
Dim b As Long
Dim ArrayCounter as Long
ArrayCounter = 1 'Or 0, depends on if you are using a zero based array or not

For a = LBound(ARRAY_Multiwage, 1) To UBound(ARRAY_Multiwage, 1)
    If ARRAY_Multiwage(a, 1) = "60021184_2018/36/HE" Then
        ARRAY_TEMP_Multiwage(ArrayCounter) = ARRAY_Multiwage(a, 1)
        Debug.Print ARRAY_TEMP_Multiwage(ArrayCounter)
        ArrayCounter = ArrayCounter + 1
    Else
        'Do nothing
    End If
 Next a

ReDim Preserve ARRAY_TEMP_Multiwage (1 To (ArrayCounter - 1))
End Sub

Answer 3

使用条件复制范围

• 下面将从工作表Sourceultiwage复制到工作表Targetultiwage都在ThisWorkbook ，包含此代码的工作簿。
• 调整包括wb在内的const ants 部分中的值。
• 此外，您可以选择复制标题（ copyHeaders ）

编码

Option Explicit

Sub copyWithCriteria()

    ' Source
    Const srcName As String = "Sourceultiwage"
    Const srcFirst As String = "A1"
    ' Target
    Const tgtName As String = "Targetultiwage"
    Const tgtFirst As String = "A1"
    ' Criteria
    Const CriteriaColumn As Long = 1
    Const Criteria As String = "60021184_2018/36/HE"
    ' Headers
    Const copyHeaders As Boolean = False
    ' Workboook
    Dim wb As Workbook: Set wb = ThisWorkbook

    ' Write values from Source Range to Source Array.
    Dim rng As Range
    Set rng = wb.Worksheets(srcName).Range(srcFirst).CurrentRegion
    Dim NoR As Long
    NoR = WorksheetFunction.CountIf(rng.Columns(CriteriaColumn), Criteria)
    Dim Source As Variant: Source = rng.Value

    ' Write values from Headers Range to Headers Array.
    If copyHeaders Then
        Dim Headers As Variant: Headers = rng.Rows(1).Value
    End If

    ' Write from Source to Target Array.
    Set rng = Nothing
    Dim UB1 As Long: UB1 = UBound(Source)
    Dim UB2 As Long: UB2 = UBound(Source, 2)
    Dim Target As Variant: ReDim Target(1 To NoR, 1 To UB2)
    Dim i As Long, j As Long, k As Long
    For i = 1 To UB1
        If Source(i, CriteriaColumn) = Criteria Then
            k = k + 1
            For j = 1 To UB2
                Target(k, j) = Source(i, j)
            Next j
        End If
    Next i

    ' Write from Target Array to Target Range.
    With wb.Worksheets(tgtName).Range(tgtFirst)
        If copyHeaders Then .Resize(, UB2).Value = Headers          ' Headers
        .Offset(Abs(copyHeaders)).Resize(NoR, UB2).Value = Target   ' Data
    End With

    ' Inform user.
    MsgBox "Data transferred.", vbInformation, "Success"

End Sub