如何使用VBA将包含特定值的行复制到Excel中的新工作表中？

2vuwiymt 于 2023-05-30 发布在其他

关注(0)|答案(1)|浏览(220)

我目前正在编写一段代码，它找到一个特定的值，然后将原始工作表中的所有行复制到包含该特定值的第二个工作表中。它的工作原理，除了我只能应用于一个文本，我需要添加51个特殊的值，需要复制。我知道这是一个很大的，但我的工作与大量的数据。如果我需要复制和粘贴某种类型的代码51次，使其工作，我会这样做，但我不能弄清楚如何使它，使这段代码查找更多的值。
此外，当代码运行时，要粘贴的工作表有一个标题，但行被粘贴在第三行而不是第二行。不知道为什么它在标题下面留下了一个空行。是否有可能将复制的行从工作表1（从那里复制）中删除？
这是我正在使用的代码，如果CStr（DataRg（I）.Value）=“Special Value”，那么我试图复制并使用不同的值，但它不起作用。

Sub NYC()

Dim DataRg As Range
Dim DataCell As Range
Dim P As Long
Dim J As Long
Dim I As Long

P = Worksheets("DLS-Route").UsedRange.Rows.Count
Q = Worksheets("NYC Source").UsedRange.Rows.Count

If I = 1 Then
    If Application.WorksheetFunction.CountA(Worksheets("NYC Source").UsedRange) = 0 Then Q = 0
End If

Set DataRg = Worksheets("DLS-Route").Range("B1:B" & P)
On Error Resume Next
Application.ScreenUpdating = False

For I = 1 To DataRg.Count
    If CStr(DataRg(I).Value) = "Special Value" Then
        DataRg(I).EntireRow.Copy Destination:=Worksheets("NYC Source").Range("A" & Q + 1)
        Q = Q + 1
    End If
Next
Application.ScreenUpdating = True
End Sub

excel

来源：https://stackoverflow.com/questions/76318324/how-can-i-copy-rows-containing-specific-values-into-a-new-sheet-in-excel-using-v

1条答案

按热度按时间

anhgbhbe1#

尝试

Sub MoveRowsBasedOnValue()
    Dim wsRoute As Worksheet
    Dim wsSource As Worksheet
    Dim lastRow As Long, i
    Dim nextRow As Long
    Dim cell As Range
    Dim specialValue As String
    Dim myarr
    
    'modify/add values to search
    myarr = Array("sv1", _
                               "sv2", _
                               "sv3")
                                   
    Set wsRoute = Worksheets("DLS-Route")
    Set wsSource = Worksheets("NYC Source")
    
    lastRow = wsRoute.Cells(wsRoute.Rows.Count, "B").End(xlUp).Row
    nextRow = wsSource.Cells(wsSource.Rows.Count, "A").End(xlUp).Row + 1
    
    For i = lastRow To 1 Step -1
        ' Check if the value is in myarr list
        If IsInArray(wsRoute.Range("B" & i), myarr) Then
            wsRoute.Rows(i).EntireRow.Cut wsSource.Rows(nextRow)
            nextRow = nextRow + 1
        End If
    Next i
    
    'delete blank rows
    Dim rng As Range
    Dim dlRow As Long

    With wsRoute
        dlRow = .Cells(.Rows.Count, "A").End(xlUp).Row
        Set rng = .Range("A1:A" & dlRow)
    End With

    On Error Resume Next
    rng.SpecialCells(xlCellTypeBlanks).EntireRow.Delete
    On Error GoTo 0
End Sub

Function IsInArray(ByVal value As String, ByVal arr As Variant) As Boolean
    Dim element As Variant
    For Each element In arr
        If StrComp(element, value, vbTextCompare) = 0 Then
            IsInArray = True
            Exit Function
        End If
    Next element
    IsInArray = False
End Function

赞(0）回复(0）举报 2023-05-30

我来回答

如何使用VBA将包含特定值的行复制到Excel中的新工作表中？

1条答案

相关问题

热门标签

最新问答