Как мне скопировать и вставить данные в рабочие листы, которые я создал в VBA для l oop?

Question

Я пытаюсь скопировать и вставить свои данные и назначить их в разные рабочие листы. Например, если столбец F равен martin 1, вся строка, содержащая martin1, будет вставлена ​​в рабочие листы («Index1»). То же самое для Charl ie 1, и он будет вставлен в листы ("Index2"). Однако я столкнулся с ошибкой, определенной здесь, как показано в моем коде ниже. Есть идеи, как ее решить?

Sub SaveRangewithConsecutiveDuplicateValuestoNewSheet()
'Define all variables
Dim wb As Workbook, ws As Worksheet, sCel As Range, rwNbr As Long

Set wb = ThisWorkbook 'Set workbook variable
Set ws = wb.Worksheets("Sheet1") 'set worksheet variable using workbook variable

Set sCel = ws.Cells(1, 6) 'Set the first start cell variable to test for duplicate values
            Dim i As Integer
            Dim site_i As Worksheet
            For i = 1 To 3
               Set site_i = Sheets.Add(after:=Sheets(Worksheets.count))
               site_i.Name = "Index" & CStr(i)
                Next i

    Application.DisplayAlerts = False
        For rwNbr = 2 To ws.Cells(ws.Rows.count, 6).End(xlUp).Offset(1).Row Step 1 'Loop

            If ws.Cells(rwNbr, 6).Value = "Martin1" Then
 ws.Range(sCel, ws.Cells(rwNbr, 6)).EntireRow.Copy Destination:=Sheets("Index1").Range("A1")
 ElseIf ws.Cells(rwNbr, 6).Value = "Charlie1" Then
    ws.Range(sCel, ws.Cells(rwNbr - ws.UsedRange.Rows.count, 6)).EntireRow.CopyDestination:=Sheets("Index2").Range("A1") '<----application defined or object defined error here

            End If

        Next rwNbr
    Application.DisplayAlerts = True
End Sub

Это ссылка на мой рабочий лист. https://www.dropbox.com/home?preview=Sample+-+Copy.xlsm

Окончательный результат должен выглядеть примерно так ...

Answer 1

Если ваши необработанные данные не имеют строки заголовка, я бы использовал al oop, чтобы собрать целевые ячейки и скопировать их соответствующим образом.

Вам нужно будет обновить ваш 3 целевых значения внутри Arr до Charlie1, Martin1 и т. Д. c.

Шаги макросов

1. L oop через каждое имя в Arr
2. L oop через каждую строку в Sheet1
3. Добавить целевую строку в Union ( набор ячеек )
4. Скопировать Union на целевой лист, где цель Sheet Index # = Arr position + 1

---

Sub Filt()

Dim ws As Worksheet: Set ws = ThisWorkbook.Sheets("Sheet1")
Dim cs As Worksheet

Dim Arr: Arr = Array("Value1", "Value2", "Value3")

Dim x As Long, Target As Long, i As Long
Dim CopyMe As Range

'Create 3 Sheets, move them to the end, rename
For x = 1 To 3
    Set cs = ThisWorkbook.Sheets.Add(After:=Sheets(ThisWorkbook.Sheets.Count))
    cs.Name = "Index" & x
Next x

lr = ws.Range("F" & ws.Rows.Count).End(xlUp).Row

'Loop through each name in array
For Target = LBound(Arr) To UBound(Arr)
   'Loop through each row
    For i = 1 To lr

        'Create Union of target rows
        If ws.Range("F" & i) = Arr(Target) Then
            If Not CopyMe Is Nothing Then
                Set CopyMe = Union(CopyMe, ws.Range("F" & i))
            Else
                Set CopyMe = ws.Range("F" & i)
            End If
        End If
    Next i

    'Copy the Union to Target Sheet 
    If Not CopyMe Is Nothing Then
        CopyMe.EntireRow.Copy Destination:=ThisWorkbook.Sheets("Index" & Target + 1).Range("A1")
        Set CopyMe = Nothing
    End If

Next Target

End Sub

---

Протестировано и работает, как и ожидалось, с моей стороны, однако ....

Если бы у вас были заголовки, это было бы намного проще с копированием / вставкой. Если вы дважды запускаете один и тот же макрос в одной и той же книге, это сломается по многим причинам, таким как дублирование имен листов, нарушение отношения между Sheet Index # = Arr Position + 1, et c ...