Я потратил часы на поиск этого и других сайтов, но не могу найти подходящего ответа, который работает с моим кодом - полное раскрытие состоит в том, что я абсолютный новичок.

У меня есть один лист в Excel, содержащий тысячи строк данных. Мой макрос (который работает!) Копирует отдельные строки данных в отдельные листы на основе критериев в столбце F. Столбец F содержит данные, такие какCCC 1 ,CC 2, ... ,CC 10, ССС 11, а макрос копирует строки в листы С1, С2, ..., С10, С11.

Моя проблема: строки, содержащиеCCC 10 иCC 11 в столбце F, копируются в лист C1, но мне нужны только строки, содержащиеCCC 1 на листе C1. Я знаю, что проблема в том, что я использую функцию 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
0
forcevba 1 Мар 2018 в 05:58

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
0
jamheadart 1 Мар 2018 в 07:03