Погите, плиз, с нумерацией в шапке и листов

Автор Ask, 25 сентября 2022, 15:15

Ask

Всем доброго времени суток!
Помогите, пожалуйста, где нужно что поменять чтобы нумерация в шапке начиналась не с 1, а с любого числа, которое я напишу?

Заранее благодарю за помощь

Sub Main_Card(bDelete As Boolean)
    Dim aData()
    Dim lRw As Long
   
    With ws0
        lRw = .Cells(.Rows.Count, 2).End(xlUp).Row: If lRw < 7 Then GoTo nxt_
        aData = .Range("A1:S" & lRw).Value
    End With
   
    With Application: .ScreenUpdating = False: .DisplayAlerts = False: End With
    If bDelete = True Then Call DeleteCard
    Call ClearData(aData)
    Call SplitData(aData)
    With Application: .ScreenUpdating = True: .DisplayAlerts = True: End With
nxt_:
    Set pRng = Nothing
End Sub

Sub DeleteCard()
    Dim sht As Worksheet
   
    If Worksheets.Count > 4 Then
        If MsgBox("Подтвердите удаление карт", 64 + vbYesNo, "УДАЛЕНИЕ КАРТ") = vbNo Then Exit Sub
       
        For Each sht In Worksheets
            If sht.Name <> ws0.Name Then
                If sht.Name <> ws1.Name Then
                    If sht.Name <> wsList.Name Then
                        If sht.Name <> wsListDep.Name Then
                            If sht.Name <> wsActivity.Name Then
                                sht.Delete
                            End If
                        End If
                    End If
                End If
            End If
        Next sht
    End If
End Sub

Sub ClearData(aData())
    Dim i As Long
   
    For i = 7 To UBound(aData)
        aData(i, 2) = Replace(Replace(aData(i, 2), ", ", ","), ".", ",")
    Next i
End Sub

Sub DepInMassive(aDep())
    Dim lRw As Long, lClmn As Long
   
    With wsListDep
        lRw = .UsedRange.Rows.Count + .UsedRange.Row - 1
        lClmn = .Cells(1, .Columns.Count).End(xlToLeft).Column
        aDep = .Range("A1").Resize(lRw, lClmn).Value
    End With
End Sub

Sub SplitData(aData())
    Dim aTmp(), aDep(), aHead(1 To 3, 1 To 1)
    Dim aSpl, aSplPos
    Dim dDate As Date
    Dim sDep As String, sStrDep As String
    Dim i As Long, n As Long, k As Long, j As Long ', p As Long
   
    If ws1.Range("C7").Value = "" Then
        dDate = Date
    Else
        dDate = ws1.Range("C7").Value
    End If
   
    Call DepInMassive(aDep)
       
    For j = 1 To UBound(aDep, 2) Step 2
        sDep = aDep(1, j)  ' отдел
       
        For i = 3 To UBound(aDep)
            If aDep(i, j) = Empty Then Exit For
            aHead(1, 1) = dDate
            aHead(2, 1) = aDep(i, j)
            aHead(3, 1) = sDep

            ReDim aTmp(1 To 100, 1 To 7)
            k = 0
           
            For n = 7 To UBound(aData)
                If InStr(aData(n, 2), sDep) Then
                    sStrDep = fStrDep(aData(n, 2), sDep)
               
                    If InStr(sStrDep, aDep(i, j) & ",") Then
                        aData(n, 2) = Replace(aData(n, 2), sStrDep, Replace(sStrDep, aDep(i, j) & ",", ""))
                   
                        k = k + 1
                        aTmp(k, 1) = aData(n, 6): aTmp(k, 2) = aData(n, 8)
                        aTmp(k, 3) = aData(n, 11): aTmp(k, 4) = aData(n, 13)
                        aTmp(k, 5) = aData(n, 15): aTmp(k, 6) = aData(n, 17)
                        aTmp(k, 7) = aData(n, 10)
                    End If
                End If
            Next n
           
            If k > 0 Then Call NewCard(aHead, aTmp, k)
        Next i
    Next j
End Sub

Function fStrDep(ByVal sText As String, sDep As String) As String
    Dim aSpl
    Dim j As Long
   
    aSpl = Split(sText, Chr$(10))
   
    For j = 0 To UBound(aSpl)
        If InStr(aSpl(j), sDep) Then
            fStrDep = aSpl(j)
            Exit Function
        End If
    Next j
End Function

Sub NewCard(aHead(), aTmp(), k As Long)
    ws1.Copy After:=Sheets(Sheets.Count)
   
    With Sheets(Sheets.Count)
        .Visible = xlSheetVisible
       
        .Range("C7:C9").Value = aHead
        .Range("C10").Value = Range("C10").Value
        .Range("A16").Resize(k, 7).Value = aTmp
       
        If pFlag = True Then
            pRng.Copy .Cells(16 + k, 1).Resize(pRng.Rows.Count, 7)
        End If
    End With
End Sub

Sub NumCard()
    Dim sTmp As String, sTxt As String, sTxt5 As String
    Dim j As Long
   
    If Worksheets.Count < 6 Then Exit Sub
    sTmp = wsList.Range("B2").Value
    sTxt = ws1.Range("A1").Value
    sTxt5 = Left$(sTxt, 5)
   
    For j = 6 To Worksheets.Count
        With Worksheets(j)
            If Left(.Range("A1").Value, 5) = sTxt5 Then .Range("A1").Value = sTxt & Replace(sTmp, "*", j - 5)
        End With
    Next j
End Sub

Администратор

файл я ваш взял, он у меня есть, можете его больше не выкладывать
вопрос у вас большой, я занят другими делами, скорее всего не смогу помочь

Администратор

Номера карт проставляются какой кнопкой? №№ карт?

Ask

Если, честно, я не знаю, там как-то из макроса собирается заголовок, потом в своде можно нажать вверху на меню №№ карт и номера добавляются автоматически

Администратор

После какой кнопки появляются номера карт? Вы же знаете, на какую кнопку щёлкаете?

Ask

Свод-меню-создать карты-да-создать карты- меню-№№ карт и после появляются номера

Администратор

Номера появляются после щелчка по какой-то кнопке?
Сначала номеров нет, а затем вы щёлкаете и номера появляются. Вы не можете понять, в какой момент появляются номера?

Ask

 меню-№№ карт и после появляются номера