当我使用 VBA 预先创建工作表时，为什么没有填充我的数据？

Question

Previously, when I created the worksheets index 1,2,3 in excel,

it can be sorted into like this in index 1 2 and 3 respectively

But now if i stop creating worksheets in excel but through VBA instead, the data cant be populated and it leaves index 1,2 and 3 empty.

This is the code that I used for populating the data but with the addition of add.sheets. The add.sheets here are for creating index1,2,3 worksheets but they doesn't trigger the program to continue to populate the data even though these worksheets exists when I program them in 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

what am I missing here and how should i solve it?

Answer 1

Your code is too confusing. If your example data is accurate, I don't understand why you need to check all three columns. You can accomplish what you are trying to do, by just using column F . If your data is already sorted as shown, then I would loop through column F testing for duplicates until no match. I would then add a worksheet and name it using the start cells' value. Then copy the rows from the start cell to the current rwNbr - 1 and paste to the new worksheet. Reset the start cell for the next group and loop.

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