Суть задачи:
Есть view в БД MS Access. И шаблон квитанции в Excel. Суть задачи: получить данные из БД, и не основе шаблона сгенерировать квитанции, подставив туда соответсвующие данные. То есть получается по сути операция типа слияние в word. В excel подобного я не нашел, посему пишу скрипт.
Весь код:
Код:
Sub Макрос2()
' Скопировать лист
Sheets("Лист1").Copy
' Костыль: вручную скопировать одну из ячеек, т.к. ее длина превышает 255 символов
Windows("Квитанция ШАБЛОН.xls").Activate
Range("B6").Select
Selection.Copy
' Костыль: вручную вставить одну из ячеек, т.к. ее длина превышает 255 символов
Windows(Windows.Count).Activate
Range("B6").Select
ActiveSheet.Paste
Range("D6").Select
ActiveSheet.Paste
Range("D12").Select
ActiveSheet.Paste
Range("B12").Select
ActiveSheet.Paste
' Добавить источник данных
Sheets.Add
Application.CutCopyMode = False
With ActiveSheet.QueryTables.Add(Connection:=Array( _
"OLEDB;Provider=Microsoft.Jet.OLEDB.4.0;Password="""";User ID=Admin;Data Source=X:\Work\Юлька\Клиенты.mdb;Mode=Read;Extended Properties=""" _
, _
""";Jet OLEDB:System database="""";Jet OLEDB:Registry Path="""";Jet OLEDB:Database Password="""";Jet OLEDB:Engine Type=5;Jet OLEDB:Datab" _
, _
"ase Locking Mode=1;Jet OLEDB:Global Partial Bulk Ops=2;Jet OLEDB:Global Bulk Transactions=1;Jet OLEDB:New Database Password="""";J" _
, _
"et OLEDB:Create System Database=False;Jet OLEDB:Encrypt Database=False;Jet OLEDB:Don't Copy Locale on Compact=False;Jet OLEDB:Co" _
, "mpact Without Replica Repair=False;Jet OLEDB:SFP=False"), Destination:= _
Range("A1"))
.CommandType = xlCmdTable
.CommandText = Array("Квитанция")
.Name = "Клиенты"
.FieldNames = True
.RowNumbers = False
.FillAdjacentFormulas = False
.PreserveFormatting = True
.RefreshOnFileOpen = False
.BackgroundQuery = True
.RefreshStyle = xlInsertDeleteCells
.SavePassword = False
.SaveData = True
.AdjustColumnWidth = True
.RefreshPeriod = 0
.PreserveColumnInfo = True
.SourceDataFile = "X:\Work\Юлька\Клиенты.mdb"
.Refresh BackgroundQuery:=False
End With
' Подготовка к вставке ссылок листа с квитанциями на ячейки с данными
'Sheets("Лист1").Select
Dim text As String
Dim collumnsInKvit As Integer
collumnsInKvit = 17
Dim kvitNum As Integer
kvitNum = 1
Dim curRow As Integer
curRow = 2
Dim curRowInKvit As Integer
curRowInKvit = 2
Dim curCollumnInKvit As Integer
curCollumnInKvit = 1 ' "A"
Dim curSecondCollumnInKvit As Integer
curSecondCollumnInKvit = 2 ' "B"
Dim sheetWithKvit As Worksheet
Set sheetWithKvit = Worksheets("Лист1")
Do While IsNull(Worksheets("Лист1").Range("A" + Str(curRow)))
' Sheets("Лист1").Select
'Sheets("Лист1").Activate
' Платеж
Dim a As Object
Worksheets("Лист1").Cells(curRowInKvit, curCollumnInKvit).FormulaR1C1 = "=Лист2!G" + Str(curRow)
' Долг
text = "=Лист2!H" + Str(curRow)
Range(curSecondCollumnInKvit + Str(curRowInKvit)).Value = text
' Адрес
text = "=Лист2!C" + Str(curRow)
Range(curSecondCollumnInKvit + Str(curRowInKvit + 1)).Value = text
' Код плательщика
text = "=Лист2!F" + Str(curRow)
Range(curCollumnInKvit + Str(curRowInKvit + 2)).Value = text
' ФИО
text = "=Лист2!D" + Str(curRow)
Range(curSecondCollumnInKvit + Str(curRowInKvit + 2)).Value = text
' Добавление страницы
If kvitNum Mod 2 = 0 Then
Range("A" + Str(curRowInKvit) + ":D" + Str(curRowInKvit + collumnsInKvit)).Copy
Range("A" + Str(curRowInKvit + collumnsInKvit)).Select
ActiveSheet.Paste
ActiveSheet.PageSetup.PrintArea = "$A$1:$D$" + Str(curRowInKvit + collumnsInKvit)
End If
' Переход к следующей квитанции
If kvitNum Mod 2 = 1 Then
curCollumnInKvit = 3 '"C"
curSecondCollumnInKvit = 4 '"D"
Else
curCollumnInKvit = 1 ' "A"
curSecondCollumnInKvit = 2 '"B"
End If
curRowInKvit = curRowInKvit + collumnsInKvit
curRow = curRow + 1
' Sheets("Лист2").Select
Sheets("Лист2").Activate
Loop
End Sub
]
Лист копирую, т.к. при копировании диапазона, почему-то не сохраняется форматирование. Вообще, оно какое-то мутное. Видимо, надо и книгу указывать, а не только лист, но она создается кодом Sheets("Лист1").Copy, и как получить имя книги не ясно.
Толковой книги так и не нашел
. Натолкните на ошибку, пожалуста.
Iska, спасибо за внимание.