Отчеты (курьерская служба)

[Hugo121]

Немного улучшил/упростил:

Option Explicit
Option Base 1

Sub NaPecatj()
    Dim a(), b(), r As Range, trep(), i&, ii&, tdata As Date, cnt As Long, ans&
    Dim adresR, adresC, komuR, komuC, kuryerR, kuryerC, dataR, dataC, nomerR, nomerC

    On Error GoTo gotoout

    cnt = Application.CountIf(Sheets("Poct").[a1].CurrentRegion.Columns(1), Selection(1))

    ans = MsgBox("Будет отобрано " & cnt & " записей на дату " & Selection(1) & vbLf & "Печатать?", vbExclamation + vbYesNo, "Печать репортов")

    If ans = vbYes Then

        Application.ScreenUpdating = False

        tdata = Selection(1).Value
        Set r = Sheets("Report").[a2:k40]
        trep = r.Value

        adresR = Array(2, 2, 12, 12, 22, 22, 32, 32)
        adresC = Array(1, 7, 1, 7, 1, 7, 1, 7)
        komuR = Array(2, 2, 12, 12, 22, 22, 32, 32)
        komuC = Array(4, 10, 4, 10, 4, 10, 4, 10)
        kuryerR = Array(6, 6, 16, 16, 26, 26, 36, 36)
        kuryerC = Array(1, 7, 1, 7, 1, 7, 1, 7)
        dataR = Array(6, 6, 16, 16, 26, 26, 36, 36)
        dataC = Array(4, 10, 4, 10, 4, 10, 4, 10)
        nomerR = Array(7, 7, 17, 17, 27, 27, 37, 37)
        nomerC = Array(4, 10, 4, 10, 4, 10, 4, 10)

        a = Sheets("Poct").[a1].CurrentRegion.Value
        b = trep: ii = 0

        For i = 2 To UBound(a)

            If a(i, 1) = tdata Then
                ii = ii + 1
                b(adresR(ii), adresC(ii)) = a(i, 4)
                b(komuR(ii), komuC(ii)) = a(i, 3)
                b(kuryerR(ii), kuryerC(ii)) = a(i, 7)
                b(dataR(ii), dataC(ii)) = a(i, 1)
                b(nomerR(ii), nomerC(ii)) = a(i, 8)

                If ii = 8 Then
                    r.Value = b: r.PrintOut
                    b = trep: ii = 0
                End If
            End If
        Next

        If ii < 8 Then r.Value = b: Sheets("Report").PrintOut
        r.Value = trep
    End If

    Application.ScreenUpdating = True
gotoout:

End Sub

[Aqil_f]

Спасибо, Hugo121. Вы очень помогли мне. Я сама что-то изменила в программе. Хотела добавить печать по дате и курьеру. В принципу работает. Если время будет, посмотрите пожалуйста, насколько корректно делала.
Еще сейчас меня такой вопрос интересует: если за день больше 8 записей будет, как печатать следующие (после 8-й) записи?

[Hugo121]

Что, Вы не попробовали напечатать 9 записей?

[Hugo121]

Посмотрел код.
1. Вероятно уже не нужно

    cnt = Application.CountIf(Sheets("Poct").[a1].CurrentRegion.Columns(1), Selection(1))

    ans = MsgBox("????? ???????? " & cnt & " ??????? ?? ???? " & Selection(1) & vbLf & "?????????", vbExclamation + vbYesNo, "?????? ????????")

    If ans = vbYes Then

...

    end if

Кстати, чтоб не было ??? - копируйте код при русской раскладке.

2. Ну и теперь в файле даты не даты, а текст. Если так всегда и часто - перед сравнением
If a(i, 1) = tdata
приводите обе половины к одному формату, например к cstr().

А так вроде должно работать, не проверял в работе.

P.S. Нет, пропустил - Preview будет мешать. Зачем?
Хотя нет, вроде не мешает. Только не Preview, а PrintPreview

[Hugo121]

Попробуйте:

Option Explicit
Option Base 1
Option Compare Text

Sub Auto_open()
    Dim a(), b(), r As Range, trep(), i&, ii&, tdata As Date
    Dim adresR, adresC, komuR, komuC, kuryerR, kuryerC, dataR, dataC, nomerR, nomerC, tdata1, kuryer2, kuryer1

    On Error GoTo gotoout

    tdata = InputBox("Ayin tarixi:", , Format(Date, "DD.MM.YYYY"))
    kuryer1 = InputBox("Kuryer:", , kuryer2)

    Application.ScreenUpdating = False
    Set r = Sheets("Report").[a2:k40]
    trep = r.Value

    adresR = Array(2, 2, 12, 12, 22, 22, 32, 32)
    adresC = Array(1, 7, 1, 7, 1, 7, 1, 7)
    komuR = Array(2, 2, 12, 12, 22, 22, 32, 32)
    komuC = Array(4, 10, 4, 10, 4, 10, 4, 10)
    kuryerR = Array(6, 6, 16, 16, 26, 26, 36, 36)
    kuryerC = Array(1, 7, 1, 7, 1, 7, 1, 7)
    dataR = Array(6, 6, 16, 16, 26, 26, 36, 36)
    dataC = Array(4, 10, 4, 10, 4, 10, 4, 10)
    nomerR = Array(7, 7, 17, 17, 27, 27, 37, 37)
    nomerC = Array(4, 10, 4, 10, 4, 10, 4, 10)

    a = Sheets("Poct").[a1].CurrentRegion.Value
    b = trep: ii = 0

    For i = 2 To UBound(a)

        If CStr(a(i, 1)) = CStr(tdata) And a(i, 7) = kuryer1 Then
            ii = ii + 1
            b(adresR(ii), adresC(ii)) = a(i, 4)
            b(komuR(ii), komuC(ii)) = a(i, 3)
            b(kuryerR(ii), kuryerC(ii)) = a(i, 7)
            b(dataR(ii), dataC(ii)) = a(i, 1)
            b(nomerR(ii), nomerC(ii)) = a(i, 8)

            If ii = 8 Then
                r.Value = b: r.PrintPreview
                b = trep: ii = 0
            End If
        End If
    Next

    If ii < 8 Then r.Value = b: Sheets("Report").PrintPreview
    r.Value = trep

    Application.ScreenUpdating = True
gotoout:

End Sub

kuryer2 только лишнее, и ещё если ничего не найдено нужно сообщить и выйти. Хотя это можно оценить глазами и не печатать.

[Aqil_f]

Спасибо, Hugo121. Пробовала Ваш код, все нормально работает.
Но, меня сейчас такой вопрос интересует: если за день больше 8 записей будет, как печатать следующие (после 8-й) записи?
Как бы 2-й лист. Первый 8 записей печатали, a потом как печатать следующие записи? Как-то отметить что эти 8 записей печатана, a потом проверить какие записи за этот день и за этого курьера не печатена?

[Hugo121]

Ну так попробуйте
Показался первый превью, распечатали, закрыли, показался второй, распечатали и т.д.
С превью даже удобнее, можно несколько раз распечатать, если вдруг бумагу зажевало.

[Hugo121]

"Как отметить напечатанные" - ну можно ставить кодом метки где-то сбоку в таблице после печати, и проверять их наличие наравне с датой и именем курьера.
Но вот как проверить что этот лист действительно распечатан - технически трудно.
Разве что такой алгоритм - сгенерили превью, после его закрытия запрос - "всё ОК, можно запротоколировать?" - если ДА, то ставим метки, идём дальше.
Вернее метки лучше писать в отдельный массив, который взяли с листа, и в котором их и ищем наравне с поиском даты и курьера.
И в конце кода выгружаем метки на лист и сразу файл сохраняем.
Ответственность на соответствие метка/действительно_напечатали на том, кто жал ОК.

[Aqil_f]

Все, все . Все правильно, моя ошибка была.

[Hugo121]

А нет, превью не помогает повторить печать!
Тогда после печати листа запрос всё ли ОК

Select Case MsgBox("", vbYesNoCancel Or vbExclamation Or vbDefaultButton1, Application.Name)

    Case vbYes

    Case vbNo

    Case vbCancel

End Select

Если vbYes - ставим метки идём дальше
Если vbNo - повторяем печать
Если vbCancel - завершаем код - т.е. сохраняем файл с метками предыдущей распечатки.