Доводка макроса

[Trimbl]

Уважаемые форумчане, здравствуйте!
В одной из тем подсмотрел макрос от IgorGO, решил подработать его для своих задач и загруз.
При запуске(Кнопка1), создаются отдельные листы для каждой единицы техники с одноименными названиями листов. Вопрос:
1.Как сделать чтобы название листа состояло из модели техники и его бортового или гос. номера? т.е. в названии листа должны присутствовать данные столбцов 3 и 4(D155E №24)
2. Как выполнить автонумерацию строк созданных листов?
3. Как организовать итоговую строку на каждом листе(сумма выданного топлива, столбец 7)?
4. Возможно ли чтобы листы создавались в отдельной книге ?
Понимаю, что вопросов много, поэтому буду весьма благодарен за любой ответ.
Благодарю за внимание.

[staniiislav]

если правильно понял и правильно сделал то так:

[Trimbl]

staniiislav - ОООгромное спасибо, все именно так, за маленьким исключением, а именно: D155E №24 и D155E №25 это однотипные бульдозера, но имеющие разные бортовые номера(№24 и №25) т.е. это абсолютно разные единицы техники и соответсвенно должны быть разнесены по разным листам(D155E №24 и D155E №25 соответственно), как и ПАЗ А676СХ и ПАЗ А767СХ имеющие разные гос. номера(А676СХ и А767СХ).
staniiislav, если Вы еще раз обратите свое внимание на данную тему - будьте добры прокомментируйте часть кода

ReDim avArr(1 To 8, 1 To 1) ' ??????
With New Collection
On Error Resume Next
For Each vItem In Range("C14:C21").Value
'Cells(Rows.Count, 1).End(xlUp) - определяет последнюю заполненную ячейку в столбце А
.Add vItem, CStr(vItem)
If Err = 0 Then
li = li + 1: avArr(li, 1) = vItem
Else: Err.Clear
End If
Next

[staniiislav]

этот код взят у Дмитрия (The_Prist) вот от сюда:
http://www.excel-vba.ru/chto-umeet-e...sya-znachenij/

как он работает можно почитать по ссылке выше (я его лишь немного переделал под ваш приме)

проверяйте, буду вопросы пишите

Option Explicit

Sub Разрезать_по_листам_в_файл()
    Dim vItem, avArr, x, x2, li As Long, i As Long, j As Long, n As Long, wb As Workbook, Fname As String

    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    'ce = Cells(Rows.Count, "C").End(xlUp).Row
    ReDim avArr(1 To 8, 1 To 1)
    With New Collection
        On Error Resume Next
        For Each vItem In Range("D14:D21").Value
        'Cells(Rows.Count, 1).End(xlUp) - определяет последнюю заполненную ячейку в столбце А
            .Add vItem, CStr(vItem)
            If Err = 0 Then
                li = li + 1: avArr(li, 1) = vItem
            Else: Err.Clear
            End If
        Next
    End With
    'If li Then [E2].Resize(li).Value = avArr
     
    x = Range("A14:I21").Value
    x2 = Range("A14:I21").Value
    Range("A11:I13").Copy
    Fname = ThisWorkbook.Path
    MkDir Fname
    Workbooks.Add xlWBATWorksheet
    
        For i = 1 To li
            If i = 1 Then
                Range("A1").PasteSpecial Paste:=xlPasteAll ', Operation:=xlNone, _
        SkipBlanks:=False, Transpose:=False
                Range("A1").PasteSpecial Paste:=xlPasteColumnWidths ', Operation:=xlNone, _
        SkipBlanks:=False, Transpose:=False
            Else
                Sheets.Add after:=Sheets(Sheets.Count)
                Range("A1").PasteSpecial Paste:=xlPasteAll ', Operation:=xlNone, _
        SkipBlanks:=False, Transpose:=False
                Range("A1").PasteSpecial Paste:=xlPasteColumnWidths ', Operation:=xlNone, _
        SkipBlanks:=False, Transpose:=False
            End If
        
            For j = 1 To UBound(x)
                If x(j, 4) = avArr(i, 1) Then
                    n = n + 1
                    x2(n, 1) = n
                    x2(n, 2) = x(j, 2)
                    x2(n, 3) = x(j, 3)
                    x2(n, 4) = x(j, 4)
                    x2(n, 5) = x(j, 5)
                    x2(n, 6) = x(j, 6)
                    x2(n, 7) = x(j, 7)
                    x2(n, 8) = x(j, 8)
                    x2(n, 9) = x(j, 9)
                End If
            Next j
            
        ActiveSheet.Name = x2(n, 3) & " " & x2(n, 4)
        [A4].Resize(n, 9).Value = x2
        Cells(4 + n, "G") = Application.Sum(Range("G4:G" & n + 3))
        n = 0
    Next i
            
    Set wb = ActiveWorkbook
    With wb
        .SaveAs Fname & "\" & "Auto Model Number" & ".xlsx", FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False  'xlNormal FileFormat:= xlOpenXMLWorkbook
        .Close
    End With
    
    On Error GoTo 0
    Application.CutCopyMode = False
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
End Sub

[Trimbl]

Спасибо, staniiislav, все ОК, без Вашей помощи я бы не осилил данную задачу. Буду разбираться на этом примере, чтобы знать как подобное чудо делается.

[staniiislav]

еще вариант с помощью словаря:

Option Explicit
Private Declare Function GetTickCount Lib "kernel32" () As Long

Sub Разрезать_по_листам_в_файл_2()
    Dim x(), x2(), i&, j&, n&, t, wb As Workbook, Fname As String, univ
    t = GetTickCount
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    
    x = Range("A14:I21").Value
    With CreateObject("scripting.dictionary")
        '.comparemode = 1
        For i = 1 To UBound(x)
            If Not .Exists(x(i, 4)) Then .Add x(i, 4), x(i, 4)
        Next i
        x = Range("A14:I21").Value
        x2 = Range("A14:I21").Value
        Range("A11:I13").Copy
        
        On Error Resume Next
        Fname = ThisWorkbook.Path
        MkDir Fname
        Workbooks.Add xlWBATWorksheet
        On Error GoTo 0
        
        univ = .Items
        For i = 1 To .Count - 1
            If i = 1 Then
                Range("A1").PasteSpecial Paste:=xlPasteAll
                Range("A1").PasteSpecial Paste:=xlPasteColumnWidths
            Else
                Sheets.Add after:=Sheets(Sheets.Count)
                Range("A1").PasteSpecial Paste:=xlPasteAll
                Range("A1").PasteSpecial Paste:=xlPasteColumnWidths
            End If
            
            For j = 1 To UBound(x)
                
                If univ(i) = x(j, 4) Then
                    n = n + 1
                    x2(n, 1) = n
                    x2(n, 2) = x(j, 2)
                    x2(n, 3) = x(j, 3)
                    x2(n, 4) = x(j, 4)
                    x2(n, 5) = x(j, 5)
                    x2(n, 6) = x(j, 6)
                    x2(n, 7) = x(j, 7)
                    x2(n, 8) = x(j, 8)
                    x2(n, 9) = x(j, 9)
                End If
            Next j
            ActiveSheet.Name = x2(n, 3) & " " & x2(n, 4)
            [A4].Resize(n, 9).Value = x2
            Cells(4 + n, "G") = Application.Sum(Range("G4:G" & n + 3))
            n = 0
        Next i
    End With
    
    Set wb = ActiveWorkbook
    With wb
        .SaveAs Fname & "\" & "Auto Model Number" & ".xlsx", FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False
        .Close
    End With
    
    On Error GoTo 0
    Application.CutCopyMode = False
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
    Debug.Print (GetTickCount - t) / 1000
End Sub

[Trimbl]

Здравствуйте форумчане!
1. staniiislav, благодарю за второй вариант, но я еще все в первом "плаваю", возникли вопросы.
а). При совпадении бортовых номеров(в отличии от гос. номеров для разных типов техники как то; - бульдозер, экскаватор, автосамосвал и т.д. они не уникальны и могут повторяться) все они(бульдозер, экскаватор, автосамосвал) попадают в один лист вновь созданной книги "Заборная ведомость", а это не правильно(см. лист Заборная ведомость, книга2 где D155E №25, а БелАЗ 5548 №25 -автосамосвал).
б). Не соображу куда вклиниться в коде, для форматирования диапазона ниже 13 строки в вновь создаваемых листах книги "Заборная ведомость" для форматирования границ и и шрифта.
в). Как отобразить присвоенное имя листа в ячейке G3 ?
г). Как при вставке шапки (стр. 1-13)в вновь создаваемых листах книги "Заборная ведомость" сохранить формат(ширина строк) ?.
д). Лист "Заборная ведомость" книги2 создан для наглядности.
2. При всей моей признательности staniiislavу буду рад помощи и других участников форума.
Спасибо за внимание.

[staniiislav]

..............................

[staniiislav]

.......................

Option Explicit

Sub Разрезать_по_листам_в_файл()
    Dim vItem, avArr, x, x2, li As Long, i As Long, k As Long, j As Long, n As Long, wb As Workbook, sh As Worksheet, Fname As String

    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    ReDim avArr(1 To Cells(Rows.Count, 1).End(xlUp).Row)
    With New Collection
        On Error Resume Next
      k = Cells(Rows.Count, 1).End(xlUp).Row
      x = Range(Cells(14, 1), Cells(k, 8)).Value
         For i = 1 To UBound(x)
            .Add x(i, 3) & "~" & x(i, 4), CStr(x(i, 3) & "~" & x(i, 4))
            If Err = 0 Then
                li = li + 1: avArr(li) = x(i, 3) & "~" & x(i, 4)
            Else: Err.Clear
            End If
        Next i
    End With
        Set sh = ActiveWorkbook.ActiveSheet
        x = Range(Cells(14, 1), Cells(k, 8)).Value
        x2 = Range(Cells(14, 1), Cells(k, 8)).Value
         Fname = ThisWorkbook.Path
         MkDir Fname
         Workbooks.Add xlWBATWorksheet
           For i = 1 To li
               If i = 1 Then
               sh.Range("A1:H13").Copy
                Range("A1").PasteSpecial Paste:=xlPasteAll
                Range("A1").PasteSpecial Paste:=xlPasteColumnWidths
            Else
                Sheets.Add after:=Sheets(Sheets.Count)
                sh.Range("A1:H13").Copy
                Range("A1").PasteSpecial Paste:=xlPasteAll
                Range("A1").PasteSpecial Paste:=xlPasteColumnWidths
               End If
            For j = 1 To UBound(x)
                  If x(j, 3) & "~" & x(j, 4) = avArr(i) Then
                    n = n + 1
                    x2(n, 1) = n
                    x2(n, 2) = x(j, 2)
                    x2(n, 3) = x(j, 3)
                    x2(n, 4) = x(j, 4)
                    x2(n, 5) = x(j, 5)
                    x2(n, 6) = x(j, 6)
                    x2(n, 7) = x(j, 7)
                    x2(n, 8) = x(j, 8)
                    x2(n, 9) = x(j, 9)
                End If
            Next j
        ActiveSheet.Name = x2(n, 3) & " " & x2(n, 4)
            [A14].Resize(n, 8).Value = x2
            Cells(3, "G") = x2(n, 3) & " " & x2(n, 4)
            Cells(14 + n, "G") = Application.Sum(Range("G14:G" & n + 13))
            Cells(14 + n, 6) = "Всего:"
            Cells(16 + n, 6) = "Выдачу произел: _____________________"
            
            sh.Range("A14:H" & n + 13).Copy
            Range("A14").PasteSpecial Paste:=xlPasteFormats
            sh.Range("A" & k + 1 & ":" & "H" & k + 1).Copy
            Range("A" & n + 13 + 1).PasteSpecial Paste:=xlPasteFormats
            Columns("G:G").EntireColumn.AutoFit
            
        n = 0
    Next i
    Set wb = ActiveWorkbook
    With wb
        .SaveAs Fname & "\" & "Заборная ведомость" & ".xlsx", FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False  'xlNormal FileFormat:= xlOpenXMLWorkbook
        .Close
    End With
    
    On Error GoTo 0
    Application.CutCopyMode = False
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
End Sub

[Trimbl]

staniiislav, благодарю за готовое решение. Единственный способ стать умнее, играть с более умным противником... - ооочень верный девиз.
Думаю, Ваши решения в данной теме помогут многим начинающим.
Тему можно закрывать.
Дякую.