Решил я вот на работе сделать прайс-брошюру то есть в виде книжки.И странно но не смог средствами екселя сделать такую штуку.Пришлось программить.Принцип такой: берем из списка определенное количество строк и копируем их в новый лист в следующем виде,1 лист с правой стороны альбомной страницы,последний с левой,предпоследний с левой 2й с правой.И так до конца списка.Затем распечатываем с двух сторон и у нас получается готовая двухсторонняя книжка .Главное избавляемся от ручной работы по копированию текста и разметки страниц.

Надеюсь кому нибудь пригодиться.
'Макрос создания брошюр в Excel
'Программирование: [email protected], icq: 194901402

Dim widthi(1000) As Double
Dim kolvostolb, kolvostrok
Public firststolb As String
Public firststolb2 As String
Public stolb As String
Public laststolb As String
Public laststolb2 As String
Public Rights As Boolean
Public aa As Integer
Public nosheet As Boolean
Public listov As Long
Public sheet As Worksheet
Public sheet1 As Worksheet
Public sheet2 As Worksheet
Public length As Integer
Public probel As Integer
Public x As Integer
Public a As Integer
Public io As Integer

Public data As Variant
Public Sub vniz()
GetDatas (firststolb + Format(aa) + ":" + laststolb + Format(aa + length)) 'читаем
If Rights Then 'пишем с правой стороны листа
PutDatas (firststolb2 + Format(a) + ":" + laststolb2 + Format(a + length))
Rights = False
Else 'пишем с левой стороны листа
PutDatas (firststolb + Format(a) + ":" + laststolb + Format(a + length))
Rights = True
End If
aa = aa + length + 1 'увеличиваем переменную номера строки для считывания
a = a + length + probel + 1 'и для записи(увеличиваем их отдельно т.к. считываем попорядку а записываем учитывая пробелы(строки))
End Sub
Public Sub vverh()
GetDatas (firststolb + Format(aa) + ":" + laststolb + Format(aa + length)) 'читаем
If Rights Then 'пишем с правой стороны листа
PutDatas (firststolb2 + Format(a) + ":" + laststolb2 + Format(a + length))
Rights = False
Else 'пишем с левой стороны листа
PutDatas (firststolb + Format(a) + ":" + laststolb + Format(a + length))
Rights = True
End If
aa = aa + length + 1 'увеличиваем переменную номера строки для считывания
a = a - (length + probel + 1) 'и для записи(увеличиваем их отдельно т.к. считываем попорядку а записываем учитывая пробелы(строки))
End Sub

Public Function roundsup(ff1 As Double) 'округление up
Dim dd As Double
dd = ff1 - Int(ff1)
If dd > 0 Then
roundsup = Int(ff1) + 1
Else
roundsup = ff1
End If
End Function

Public Sub cycle()
Dim seredina As Integer
If roundsup(listov / 2) Mod 2 = 0 Then 'число листов в книге(а не списке)
seredina = roundsup(listov / 2) 'кратно 2
Else
seredina = roundsup(listov / 2) + 1
End If

For x = 1 To seredina
vniz
Next x

a = a - (length + probel + 1)
For x = 1 To listov - seredina
vverh
Next x

End Sub
Public Sub createlist()
nosheet = True
For Each sheet In ActiveWorkbook.Worksheets 'проверяем все листы в активной книге
If InStr(1, sheet.Name, "Created") Then 'и ищем с наличие того имени,которое хотим создать
nosheet = False
End If
Next sheet

If nosheet Then
Set sheet2 = Worksheets.Add
sheet2.Name = "Created"
cycle
Else
k = MsgBox("Извините но лист с именем Created уже существует", 0, "Ошибка")
End If
End Sub
Public Sub GetDatas(N1 As String)
data = sheet1.Range(N1) 'читаем
End Sub
Public Sub PutDatas(N2 As String)
sheet2.Range(N2) = data 'вставляем
End Sub

Private Function dlin(m As String, m2 As String) As Integer
x = 0
Do
x = x + 1
st = Mid(m, x, 1)
Loop Until (st = m2)
dlin = x - 1
End Function


Public Sub Кнопка9_Щелкнуть()
Set sheet1 = ActiveSheet
rast = Userform1.TextBox3.Value + 1 'расстояние между страницами в ширину

kolvostolb = sheet1.UsedRange.Columns.Count 'подсчитываем количество используемых столбцов
kolvostrok = sheet1.UsedRange.Rows.Count 'с помощью выделения
stolb = sheet1.UsedRange.Address(rowAbsolute = False, columnabsolute:=False)
io = dlin(stolb, "$")
firststolb = Left(stolb, io) 'адрес(буква) начального столбца
stolb = Right(stolb, Len(stolb) - io - 1)
io = dlin(stolb, "$")
laststolb = Left(stolb, io) 'вырезаем адрес
io = dlin(laststolb, ":")
laststolb = Right(laststolb, Len(laststolb) - io - 1) 'конечный столбец

stolb = Cells(1, laststolb).Offset(0, rast).Address(ReferenceStyle:=xlA1, columnabsolute:=False) 'вырезаем
io = dlin(stolb, "$") 'адрес страницы с правой стороны листа
firststolb2 = Left(stolb, io)

stolb = Cells(1, firststolb2).Offset(0, kolvostolb - 1).Address(ReferenceStyle:=xlA1, columnabsolute:=False) 'вырезаем
io = dlin(stolb, "$") 'адрес страницы с правой стороны листа
laststolb2 = Left(stolb, io)


length = Userform1.TextBox1.Value - 1 'количество строк на странице
listov = roundsup(kolvostrok / length) 'кол.во страниц в книге
a = 1 'Начальный Номер строки для чтения
aa = 1 'Начальный Номер строки для записи
Rights = True 'начинаем с правой стороны листа вставлять
probel = Userform1.TextBox2.Value 'количество пустых строк промежутков между страницами

For x = 1 To kolvostolb 'читаем ширину столбцов
widthi(x) = Columns(x).ColumnWidth
Next x
createlist 'создаем лист

For x = 1 To kolvostolb
Columns(x).ColumnWidth = widthi(x) 'записываем ширину
Columns(x + (kolvostolb + rast - 1)).ColumnWidth = widthi(x) 'столбцов в новый лист
Next x
End Sub

Кому лень вставлять в ексель, вот адрес для скачивания куда макрос с формой положил саморасп.архив: http://www.darklibr.narod.ru/vba.exe



([email protected]) Ж-)