Заполнение почтового бланка

[Kefirrr]

Не так давно мне очень сильно помогли на этом форуме, поэтому считаю своим долго выложить свои наработки по части автоматического заполнения почтового бланка. Файл еще требует ОГРОМНОЙ доработки, но зато теперь формирует индекс. Надеюсь это кому-нибудь понадобиться.
Так же надеюсь на помощь форумчан по части:
1)как уменьшить макрос (т.к. каждая цифра индекса у меня формируется отдельно, и поэтому файл начинает подтормаживать)
2) как сделать так, чтобы сумма писалась прописью (в данном файле я просто на бланке написала)
3)у меня адрес написан в одну строчку, как сделать так, чтобы переносил слова на другую строчку
4) как изменить ФИО получателя в Р.падеж

P.S. рано или поздно я найду решение, но если кто-нибудь поможет ускорить этот процесс буду премного благодарна.

[EducatedFool]

попробую ответить на вопросы:

1) на отдельном (возможно, скрытом) листе рисуете все цифры индекса от 0 до 9
и назначаете диапазонам ячеек имена типа digit0, digit1 и т.д.
Потом в цикле проходите по значению индекса, и копируете нужные цифры со скрытого листа
Как-то так будет выглядеть:

index$ = Cells(ActiveCell.Row, 3)
for i& = 1 to 6
   digit$ = mid(index$,i,1) ' берем очередную цифру индекса
   ' копируем её (со скрытого листа) на позицию очередной цифры (со смещением относительно позиции первой цифры)
   worksheets("имя_скрытого_листа").range("digit" & digit$).copy Sheets("Форма_7-а").Cells(31, 9).offset(0, (i-1)*2)
next

2) сумма прописью? достаточно эту фразу вставить в яндекс, - как тут же найдете кучу примеров этой функции на VBA

3) лучше под адрес сделать одну объединённую ячейку, я включить в этой ячейке перенос по словам

4) вы поиском вообще не пользуетесь?
первый результат выдачи по запросу «VBA родительный падеж»
http://excelvba.ru/code/GenitiveCase


И ещё: добавление в самом начале макроса строки

Application.ScreenUpdating = False

а в конце - строки

Application.ScreenUpdating = True

заметно ускорит заполнение бланка

[Казанский]

1) Теперь я понимаю, как люди умудряются получать ошибку компилятора "Procedure too large"
Вот так может выглядеть процедура рисования одной цифры. В процедуру передается диапазон - верхняя ячейка цифры, и число-цифра (0-9).
Ниже - тестовая процедура. Нажимайте F5 для продолжения.

Option Explicit

Const D = "110101110 010011000 111000110 101010001 011101000 " & _
  "101101100 001011110 100010010 111101110 111100001"

Sub DrawDigit(c As Range, i As Long)
Dim s$, n, j&
s = Split(D)(i)
With c.MergeArea
  For Each n In Array(xlEdgeTop, xlEdgeRight, xlEdgeBottom, xlEdgeLeft, xlDiagonalUp)
    j = j + 1
    .Borders(n).Weight = IIf(Mid$(s, j, 1) = "0", xlHairline, xlThick)
  Next
End With
With c.Offset(1).MergeArea
  For Each n In Array(xlEdgeRight, xlEdgeBottom, xlEdgeLeft, xlDiagonalUp)
    j = j + 1
    .Borders(n).Weight = IIf(Mid$(s, j, 1) = "0", xlHairline, xlThick)
  Next
End With
End Sub

Sub test()
Dim i&
Sheets.Add
Columns("B:E").ColumnWidth = 0.75
Rows(2).RowHeight = 25
Range("3:4").RowHeight = 12.5
Range("B2:E2").Merge
Range("B3:E4").Merge

For i = 0 To 9
  DrawDigit [b2], i
  Stop
Next
End Sub

[Казанский]

Еще короче, но менее прозрачно

Const D = "854 529 476 173 666 910 969 69 990 190"

Sub DrawDigit(c As Range, i As Long)
Dim ptrn&, n&, bit&, topBot&
ptrn = Split(D)(i)
bit = 1
For topBot = 0 To 1
  With c.Offset(topBot).MergeArea
    For n = 6 To 10
      .Borders(n).Weight = IIf(ptrn And bit, xlThick, xlHairline)
      bit = bit + bit
    Next
  End With
Next
End Sub

Sub test()
Dim i&
Sheets.Add
Columns("B:E").ColumnWidth = 0.75
Rows(2).RowHeight = 25
Range("3:4").RowHeight = 12.5
Range("B2:E2").Merge
Range("B3:E4").Merge

For i = 0 To 9
  DrawDigit [b2], i
  Stop
Next
End Sub

[IgorGO]

аналогичное по подходу и степени непонятности решение:

Sub test()
  Dim i As Long
  For i = 0 To 9
    Indx Cells(10, i * 2 + 2), i
  Next
End Sub

Sub Indx(rg As Range, d As Long)
  Const d0 As String = "5658 4368 5129 1285 4628 1564 2334 1282 7710 5637"
  Dim i As Long
  For i = 0 To 9
    If Int(Val(Split(d0)(d)) / 256 ^ (1 - Int(i / 5))) And 2 ^ (i Mod 5) _
      Then rg.Offset(Int(i / 5), 0).Borders(i Mod 5 + 6).Weight = xlMedium
  Next
End Sub

[EducatedFool]

Игорь, раньше ты только формулами трехэтажными нам мозг выносил,
а теперь и за макросы взялся?

Это ж надо так код писать, что, пока его не запустишь, — ни за что не догадаешься, что он делает))
С таким подходом к программированию, никаких обфускаторов кода не понадобится...

[IgorGO]

если догадаться как описаны верхняя и нижняя часть цифры - то все довольно просто)))
вот так чуть проще:

Sub Indx2(rg As Range, d As Long)
  Const d0 As String = "346:356 26:6 46:25 24:24 356:6 345:56 25:356 24:3 3456:356 3456:2"
  Dim i As Long, n As Long:  n = 0
  For i = 1 To Len(Split(d0)(d))
    If Mid(Split(d0)(d), i, 1) = ":" Then n = 1 Else rg.Offset(n, 0).Borders(Val(Mid(Split(d0)(d), i, 1)) + 4).Weight = xlMedium
  Next
End Sub

в строке d0 описаны цифры от 0 до 9
до двоеточия : описана верхняя часть изображения цифры, после - нижняя
1 - диагональ слева-сверху вправо-вниз (в изображениях цифр не используется, но пусть будет для универсальности)
2 - дмагональ слева-снизу вправо-вверх
3 - левая
4 - верхняя
5 - нижняя
6 - правая сторона

[IgorGO]

а если это почитать - должно отпустить от прочитанного ранее

Sub Indx3(rg As Range, d As Long)
  Const d0 As String = "лвп:лнп +п:п вп:+н +в:+в лп:вп лвн:нп +:лпвн +в:л лвп:лвнп лвнп:+"
  Dim i As Long, n As Long, c As String:  n = 0
  For i = 1 To Len(Split(d0)(d))
    c = Mid(Split(d0)(d), i, 1)
    If c = ":" Then n = 1 Else rg.Offset(n, 0).Borders(BrdNum(c)).Weight = xlMedium
  Next
End Sub


Function BrdNum(s As String) As Long
  Select Case s
  Case "-"
    BrdNum = 5
  Case "+"
    BrdNum = 6
  Case "л"
    BrdNum = 7
  Case "в"
    BrdNum = 8
  Case "н"
    BrdNum = 9
  Case "п"
    BrdNum = 10
  End Select
End Function