求VBA代码：提取满足条件的Excel工作表A列数据至空白表

Got it, let's solve this problem efficiently using VBA with array storage (way faster than copying rows one by one!). Here's a complete solution tailored to your needs:

Full VBA Code #

Sub ExtractTargetRows()
    Dim wsSource As Worksheet, wsTarget As Worksheet
    Dim lastRow As Long, i As Long, j As Long
    Dim resultArr() As Variant, arrIndex As Integer
    
    ' Set your source and target worksheets - change names as needed!
    Set wsSource = ThisWorkbook.Worksheets("DataSheet") ' Replace with your data sheet name
    Set wsTarget = ThisWorkbook.Worksheets("BlankSheet") ' Replace with your blank sheet name
    
    ' Get the last used row in source sheet (column A as reference)
    lastRow = wsSource.Cells(wsSource.Rows.Count, "A").End(xlUp).Row
    
    ' Initialize array and index
    ReDim resultArr(1 To lastRow) ' Start with max possible size
    arrIndex = 0
    
    ' Loop through each row from 1 to lastRow (adjust start row if header exists)
    For i = 1 To lastRow
        ' Check columns B to AH (column numbers 2 to 34)
        Dim hasValidValue As Boolean
        hasValidValue = False
        
        For j = 2 To 34 ' Column B is 2, AH is 34
            ' Check if cell is not empty AND value is between 1-5 (integer)
            If Not IsEmpty(wsSource.Cells(i, j)) Then
                If IsNumeric(wsSource.Cells(i, j)) Then
                    If wsSource.Cells(i, j).Value >= 1 And wsSource.Cells(i, j).Value <= 5 Then
                        hasValidValue = True
                        Exit For ' No need to check other columns once found
                    End If
                End If
            End If
        Next j
        
        ' If valid value found, add column A to array
        If hasValidValue Then
            arrIndex = arrIndex + 1
            resultArr(arrIndex) = wsSource.Cells(i, "A").Value
        End If
    Next i
    
    ' Resize array to actual number of results
    If arrIndex > 0 Then
        ReDim Preserve resultArr(1 To arrIndex)
        ' Paste array to target sheet starting at A1
        wsTarget.Range("A1").Resize(arrIndex, 1).Value = Application.Transpose(resultArr)
    Else
        MsgBox "No rows found matching the criteria!"
    End If
    
    ' Cleanup
    Set wsSource = Nothing
    Set wsTarget = Nothing
End Sub

Key Explanations #

• Worksheet Setup: First, we define the source (data-containing) and target (blank) sheets. Make sure to replace the sheet names with your actual ones!
• Last Row Detection: We use End(xlUp) on column A to find the last used row, which works even if there are gaps in other columns.
• Column Loop: Instead of referencing column letters, we use column numbers (B=2, AH=34) for easier looping. For each row, we check every column from 2 to 34.
• Validation Check: We first check if the cell is not empty, then confirm it's a number between 1 and 5. Once we find a valid value in the row, we stop checking further columns to save time.
• Array Storage: We collect all matching A-column values in an array, then paste them all at once. This is way more efficient than copying/pasting each row individually, especially for large datasets.
• Final Paste: We resize the array to match the number of valid results, then transpose it (since arrays are 1D and we need a column range) and paste to the target sheet.

Notes #

• If your data has a header row, adjust the For i = 1 To lastRow line to start at i = 2 to skip the header.
• The code includes a check for no matching rows, which will show a message box if nothing is found.

内容的提问来源于stack exchange，提问作者Bimmie