VBA 通过 arrays 移动行

Question

I am pretty new with arrays in VBA, and need some help finishing a code...

The objective is to copy from one array to another if a value in the first part of the array is found. Here's what I have so far, and I have put comments in the lines that I am struggling with.

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

Any help would be greatly appreciated

Answer 1

Try this out. What you are looking for is ReDim option to dynamically expand an array before entering data into the newest slot.

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

I tend to use a Long data type variable as a counter within the loop for the destination array, that way each time the array is accessed, a new element can be written to. In past I've been steered towards declaring the new array with the maximum upper bound it could hold and resize it once at the end so the below example will follow that.

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

Copy Range With Criteria

• The following will copy from worksheet Sourceultiwage to worksheet Targetultiwage both in ThisWorkbook , the workbook containing this code .
• Adjust the values in the const ants section including wb .
• Additionally you can choose to copy headers ( copyHeaders )

The Code

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