Почему мои данные не заполняются, когда я заранее использовал VBA для создания таблиц?

Question

Ранее, когда я создавал листы с индексом 1,2,3 в Excel,

его можно отсортировать следующим образом в индексах 1 2 и 3 соответственно

Но теперь, если я перестану создавать листы в Excel, а через VBA вместо этого, данные не могут быть заполнены, и индексы 1,2 и 3 останутся пустыми.

Это код, который я использовал для заполнения данных, но с добавлением add.sheets. Добавленные здесь листы предназначены для создания рабочих листов index1,2,3, но они не запускают программу для заполнения данных, даже если эти рабочие листы существуют, когда я программирую их в VBA.

 Sub UpdateVal()
        Static count As Long
        Dim iRow As Long
        Dim aRow As Long
        Dim a As Long
        Dim b As Long
        Dim selectRange As Range
        Dim lastline As Integer
        Dim sheetname As String
        Dim indexrowcount As Integer
        Dim wb As Workbook
        Dim ws As Worksheet
        Set wb = ActiveWorkbook
        Set ws = wb.Worksheets("Result")
        Set site_ai = Sheets.Add(after:=Sheets(Worksheets.count)) 
        site_ai.Name = "Index1"
        Set site_bi = Sheets.Add(after:=Sheets(Worksheets.count))
        site_bi.Name = "Index2"
        Set site_ci = Sheets.Add(after:=Sheets(Worksheets.count))
        site_ci.Name = "Index3"**


       '^additional codes sheets.Add added here for creating worksheets namely index1,2,3



        j = 2
        iRow = 1
        lastline = ws.UsedRange.Rows.count
        While iRow < lastline + 1
            a = iRow + 1
            b = iRow + 17 ' Max Group Size with Same name in F to H column
            count = 1
            If ws.Cells(iRow, "F").Value = "Martin1" Then
                sheetname = "Index1"
            ElseIf ws.Cells(iRow, "F").Value = "John1" Then
                sheetname = "Index2"
            Else
                sheetname = "Index3"
            End If
            For aRow = a To b
                If ws.Cells(iRow, "F") = ws.Cells(aRow, "F") And ws.Cells(iRow, "G") = ws.Cells(aRow, "G") And ws.Cells(iRow, "H") = ws.Cells(aRow, "H") Then
                    count = count + 1
                Else
                    Set selectRange = Range("A" & iRow & ":J" & aRow - 1)
                    selectRange.Copy
                    indexrowcount = Sheets(sheetname).UsedRange.Rows.count
                    Sheets(sheetname).Range("A" & indexrowcount).PasteSpecial xlPasteAll
                    iRow = iRow + count
                    Exit For
               End If
            Next aRow
        Wend
    End Sub

что я здесь скучаю и как мне это решить?

Answer 1

Ваш код слишком запутанный. Если данные вашего примера точны, я не понимаю, зачем вам проверять все три столбца. Вы можете sh выполнить то, что пытаетесь сделать, просто используя column F. Если ваши данные уже отсортированы, как показано, то я буду проверять дубликаты с l oop по column F, пока не будет найдено совпадение. Затем я бы добавил лист и назвал его, используя значение начальных ячеек. Затем скопируйте строки из начальной ячейки в текущую rwNbr - 1 и вставьте в новую рабочую таблицу. Сбросить начальную ячейку для следующей группы и l oop.

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

    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 <> sCel.Value Then 'loop until the value changes
                wb.Sheets.Add(After:=wb.Sheets(wb.Sheets.count)).Name = sCel.Value 'Add sheet and name based on the first cell of group

                ws.Range(sCel, ws.Cells(rwNbr - 1, 6)).EntireRow.Copy Destination:=ActiveSheet.Range("A1") 'select group of consecutive duplicates

                Set sCel = ws.Cells(rwNbr, 6) 'reset start cell to test for the next group of consecutive duplicates
            End If

        Next rwNbr
    Application.DisplayAlerts = True
End Sub