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