Question

我花了好几个小时搜索这个网站和其他网站，但找不到适用于我的代码的适用答案 - 完全披露我是一个初学者。

我在excel中有一张包含1000行数据的表。我的宏（有效！）根据F列中的标准将各行数据复制到单独的表中。列F包含CCCC 1，CCCC 2，...，CCCC 10，CCCC 11等数据，宏将行复制到表C1，C2，......，C10，C11。

我的问题：F列中包含CCCC 10和CCCC 11的行正被复制到C1表中，但我只想要在C1表中包含CCCC 1的行。我知道问题是我正在使用InStr函数，但我无法找到解决方案。

重要说明：并非每一行都有F列中的数据，而且我的目标表中有列标题。

提前感谢您的任何帮助

Sub SortVintage()
Dim r As Long, sv1 As Long, sv2 As Long
sv1 = Sheets("Input").Cells(Rows.Count, "A").End(xlUp).Row
sv2 = Sheets("C1").Cells(Rows.Count, "A").End(xlUp).Row
sv3 = Sheets("C2").Cells(Rows.Count, "A").End(xlUp).Row
sv4 = Sheets("C3").Cells(Rows.Count, "A").End(xlUp).Row
sv5 = Sheets("C4").Cells(Rows.Count, "A").End(xlUp).Row
sv6 = Sheets("C5").Cells(Rows.Count, "A").End(xlUp).Row
sv7 = Sheets("C6").Cells(Rows.Count, "A").End(xlUp).Row
sv8 = Sheets("C7").Cells(Rows.Count, "A").End(xlUp).Row
sv9 = Sheets("C8").Cells(Rows.Count, "A").End(xlUp).Row
sv10 = Sheets("C9").Cells(Rows.Count, "A").End(xlUp).Row
sv11 = Sheets("C10").Cells(Rows.Count, "A").End(xlUp).Row
sv12 = Sheets("C11").Cells(Rows.Count, "A").End(xlUp).Row
For r = sv1 To 2 Step -1
    If InStr(1, (Range("F" & r).Value), "CCCC 1") > 0 Or _
    InStr(1, (Range("F" & r).Value), "Series 1") > 0 Then
        Rows(r).Copy Destination:=Sheets("C1").Range("A" & sv2 + 1)
        sv2 = Sheets("C1").Cells(Rows.Count, "A").End(xlUp).Row
    End If
    If InStr(1, (Range("F" & r).Value), "CCCC 2") > 0 Or _
    InStr(1, (Range("F" & r).Value), "Series 2") > 0 Then
        Rows(r).Copy Destination:=Sheets("C2").Range("A" & sv3 + 1)
        sv3 = Sheets("C2").Cells(Rows.Count, "A").End(xlUp).Row
    End If
    If InStr(1, (Range("F" & r).Value), "CCCC 3") > 0 Or _
    InStr(1, (Range("F" & r).Value), "Series 3") > 0 Then
        Rows(r).Copy Destination:=Sheets("C3").Range("A" & sv4 + 1)
        sv4 = Sheets("C3").Cells(Rows.Count, "A").End(xlUp).Row
    End If
    If InStr(1, (Range("F" & r).Value), "CCCC 4") > 0 Or _
    InStr(1, (Range("F" & r).Value), "Series 4") > 0 Or _
    InStr(1, (Range("F" & r).Value), "Series 4, Series 5") > 0 Then
        Rows(r).Copy Destination:=Sheets("C4").Range("A" & sv5 + 1)
        sv5 = Sheets("C4").Cells(Rows.Count, "A").End(xlUp).Row
    End If
    If InStr(1, (Range("F" & r).Value), "CCCC 5") > 0 Or _
    InStr(1, (Range("F" & r).Value), "Series 5") > 0 Then
        Rows(r).Copy Destination:=Sheets("C5").Range("A" & sv6 + 1)
        sv6 = Sheets("C5").Cells(Rows.Count, "A").End(xlUp).Row
    End If
    If InStr(1, (Range("F" & r).Value), "CCCC 6") > 0 Or _
    InStr(1, (Range("F" & r).Value), "Series 6") > 0 Then
        Rows(r).Copy Destination:=Sheets("C6").Range("A" & sv7 + 1)
        sv7 = Sheets("C6").Cells(Rows.Count, "A").End(xlUp).Row
    End If
    If InStr(1, (Range("F" & r).Value), "CCCC 7") > 0 Or _
    InStr(1, (Range("F" & r).Value), "Series 7") > 0 Then
        Rows(r).Copy Destination:=Sheets("C7").Range("A" & sv8 + 1)
        sv8 = Sheets("C7").Cells(Rows.Count, "A").End(xlUp).Row
    End If
    If InStr(1, (Range("F" & r).Value), "CCCC 8") > 0 Or _
    InStr(1, (Range("F" & r).Value), "Series 8") > 0 Then
        Rows(r).Copy Destination:=Sheets("C8").Range("A" & sv9 + 1)
        sv9 = Sheets("C8").Cells(Rows.Count, "A").End(xlUp).Row
    End If
    If InStr(1, (Range("F" & r).Value), "CCCC 9") > 0 Or _
    InStr(1, (Range("F" & r).Value), "Series 9") > 0 Then
        Rows(r).Copy Destination:=Sheets("C9").Range("A" & sv10 + 1)
        sv10 = Sheets("C9").Cells(Rows.Count, "A").End(xlUp).Row
    End If
    If InStr(1, (Range("F" & r).Value), "CCCC 10") > 0 Or _
    InStr(1, (Range("F" & r).Value), "Series 10") > 0 Then
        Rows(r).Copy Destination:=Sheets("C10").Range("A" & sv11 + 1)
        sv11 = Sheets("C10").Cells(Rows.Count, "A").End(xlUp).Row
    End If
    If InStr(1, (Range("F" & r).Value), "CCCC 11") > 0 Or _
    InStr(1, (Range("F" & r).Value), "Series 11") > 0 Then
        Rows(r).Copy Destination:=Sheets("C11").Range("A" & sv12 + 1)
        sv12 = Sheets("C11").Cells(Rows.Count, "A").End(xlUp).Row
    End If
Next r
End Sub

Answer 1

请尝试使用此例程：

Sub HeyHo()

Dim SV1 As Long
Dim cVal As String
Dim lROW As Long
Dim r As Long
Dim t As Long
Dim WS As Worksheet

Set WS = ThisWorkbook.Worksheets("Input") 'Sets WS to your main input sheet
SV1 = WS.Cells(WS.Rows.Count, "A").End(xlUp).Row 'Find last row in input

On Error Resume Next

    For r = SV1 To 2 Step -1                ' Cycle through input from bottom to 2nd row
        t = 0
        cVal = WS.Cells(r, "F").Value2      ' set cVal to = "F" cell value
        t = Right(cVal, Len(cVal) - InStrRev(cVal, " ")) ' Extract rightmost value of "F" cell value
        If t = 5 Then If InStr(1, cVal, 4) Then t = 4 ' if t is 5 double check it isn't the Series 4, Series 5 possibility
        If t > 0 Then                       ' if no number was found then exit loop for this row else:
        With ThisWorkbook.Worksheets("C" & t) ' specify sheet where t is the extracted number
            lROW = .Cells(.Rows.Count, 1).End(xlUp).Row + 1 ' get lastrow + 1 of the worksheet
            WS.Rows(r).Copy Destination:=.Range("A" & lROW) ' copy row r from WS (Input) to specified t sheet lastrow + 1
        End With
        End If
    Next r

End Sub

VBA - 使用if语句＆amp;需要在一个范围内找到完全匹配

1 个答案: