excel - Excel VBA Append Cell to a different sheet Based on a column in same row saying "Yes"

Question

Ok I have tried and failed here, but I have 2 sheets in the same workbook.

Sheet "AF" and sheet "CurrentList".

If Column S in the sheet "CurrentList" says "Yes" I want to append Column R in that same row to the bottom of a running list in Sheet "AF". Sheet AF may already have 50000 values in there, so it has to append to the very bottom of the list.

I started trying to break apart some other code but it's throwing tons of errors, so not sure this is the approach:

Sub AddData()
 Dim wsDA As Worksheet, wsD As Worksheet, lastRDA As Long, lastRD As Long
 Dim arrDA As Variant, rngDel As Range, arrD As Variant, arrCopy As Variant
 Dim i As Long, j As Long, k As Long
 
 Set wsDA = Worksheets("CurrentList")
 Set wsD = Worksheets("AF")
 lastRDA = wsDA.Range("R" & Rows.Count).End(xlUp).Row
 lastRD = wsD.Range("A" & Rows.Count).End(xlUp).Row
 'I got completely lost at this point..
 arrDA = wsDA.Range("R:" & lastRDA).Value
 arrD = wsD.Range("A1" & lastRDA).Value
 
 ReDim arrCopy(1 To 2, 1 To UBound(arrDA))
 
 For i = 1 To UBound(arrDA)
    If arrDA(i, 10) = "Yes" Then
        k = k + 1: arrCopy(1, k) = arrDA(i, 1): arrCopy(2, k) = arrDA(i, 2)
        arrCopy(2, k) = arrDA(i, 3)
    End
 End If
End Sub

 

标签： excelvbalistappend

Answer 1

VBA 查找

提示

• 不要忘记工作簿。
• 使用描述性变量名称。
• 添加一些评论。没有我做的那么多，但评论每个部分。

编码

Option Explicit

Sub AddData()
    
    ' Write values from Source Range to Lookup and Result Arrays.
    
    ' Define workbook.
    Dim wb As Workbook
    Set wb = ThisWorkbook ' The workbook containing this code.
    ' Define Source Worksheet.
    Dim src As Worksheet
    Set src = wb.Worksheets("CurrentList")
    ' Define Source Last Row.
    Dim LastRow As Long
    LastRow = src.Cells(src.Rows.Count, "S").End(xlUp).Row
    ' Define Source Lookup Column Range.
    Dim rng As Range
    Set rng = src.Range("S1").Resize(LastRow)
    ' Write values from Source Lookup Column Range to Lookup Array.
    Dim Lookup As Variant
    Lookup = rng.Value
    ' Define Source Result Column Range.
    Set rng = src.Range("R1").Resize(LastRow)
    ' Write values from Source Result Column Range to Result Array.
    Dim Result As Variant
    Result = rng.Value
    
    ' Status: We have two arrays of the same size. We are going
    '         look for "Yes" in Lookup Array and write the corresponding
    '         value in Result Array to Result Array, yes, to the same array.
    '         We cannot get more matching results, so there will be no overflow.
    '         We will count the number of matches (MatchCount) to later know
    '         how many values to write to the Destination Range.
    
    ' Write values from Lookup and Result Arrays to Result Array (No typo).
    
    Dim LookupValue As Variant ' Current Lookup Value: the value
                               ' in the current element of Lookup Array
    Dim i As Long              ' Lookup/Result Array Counter (same size)
    Dim MatchCount As Long     ' Match Counter
    
    ' Iterate rows (values) in Lookup Array.
    For i = 1 To UBound(Lookup)
        ' Write value of current element in Lookup Array to Lookup Value
        LookupValue = Lookup(i, 1)
        ' Check if Lookup Value is not an error value.
        If Not IsError(LookupValue) Then
            ' Check if Lookup Value is equal to the Criteria ("Yes").
            If LookupValue = "Yes" Then
                ' Increase the Match Count.
                MatchCount = MatchCount + 1
                ' Write value of current element in Result Array
                ' to the position determined by Match Count to itself.
                Result(MatchCount, 1) = Result(i, 1)
            End If
        End If
    Next i
    ' Validate Match Count.
    If MatchCount = 0 Then ' No match was found.
        Exit Sub
    End If
    
    ' Write values from Result Array to Destination Range.
        
    ' Define Destination Worksheet.
    Dim dst As Worksheet
    Set dst = wb.Worksheets("AF")
    ' Define Destination First Cell, the cell after the last non-empty cell.
    Set rng = dst.Cells(dst.Rows.Count, "A").End(xlUp).Offset(1)
    ' Define Destination Range.
    ' Note that you can resize only an array's last dimension which in our case
    ' is columns, and not rows. So we resize the resulting
    ' Destination range only to the size of Match Count, not to
    ' the size of 'UBound(Result, 1)'.
    Set rng = rng.Resize(MatchCount)
    ' Write values from Result Array to Destination Range.
    rng.Value = Result
        
    ' Inform user.
    
    MsgBox "Data transferred.", vbInformation, "Success"
    
End Sub