» Excel VBA (часть 2)

Я хочу чтобы в защищенном листе, в незащищенной ячейке, при копировании не переносился формат ячейки, а вставлялись только значения, т.е. не менялся формат ячейки.

Добавлено:
[q][/q]

Я хочу, чтобы в защищенном листе, в незащищенной ячейке, при копировании не переносился формат ячейки, а вставлялись только значения, т.е. не менялся формат ячейки. Так просто изменить формат Excel не дает, что меня устраивает. Не устраивает, то что именно при копировании переноситься и формат.

Цитата:

Я хочу, чтобы в защищенном листе, в незащищенной ячейке, при копировании не переносился формат ячейки, а вставлялись только значения, т.е. не менялся формат ячейки. Так просто изменить формат Excel не дает, что меня устраивает. Не устраивает, то что именно при копировании переноситься и формат.

куда не переносился? зачем не переносился? Почему только в незащищенной? В защищенной я также могу скопировать ячейку, и в буфер обмена попадает и форматирование этой ячейки. А что мешает сделать "копи-вставка значения"?
Я так и не понял чего вы хотите?
Особенно умиляют такие перлы

Цитата:

Но копировании, все равно переносить формат ячейки.

1. Суть из ваших слов не ясна.
2. Постарайтесь без ошибок писать, т.к. при неправильном склонении даже правильно сформулированная идея теряет свою ясность
Я понял что есть защищенный лист, и незащищенная ячейка на нем. Дальше что надо?
Вы боитесь что с защищенного листа утащат ваше форматирование? Или отформатируют незащищенные ячейки на этом листе?

Бабки-угадки, блин

Цитата:

1. Суть из ваших слов не ясна.
2. Постарайтесь без ошибок писать, т.к. при неправильном склонении даже правильно сформулированная идея теряет свою ясность
Я понял что есть защищенный лист, и незащищенная ячейка на нем. Дальше что надо?
Вы боитесь что с защищенного листа утащат ваше форматирование? Или отформатируют незащищенные ячейки на этом листе?

Постараюсь объяснить еще раз.
Есть ячейка A1 и B1
Функция «защищаемая ячейка» в A1 и B1 не установлена.
Лист защищен. Значение «форматирование ячеек» - не установлена.
Соответственно программа не дает возможность изменять формат ячейки.

При копировании значение из ячейки А1 в ячейку В1 вместе со значением переносятся и форматы.

Вопрос в следующем: как программно ограничить изменение форматов ячейки В1?

leoway
понятненько...
1. форматирование ячейки А1 можно не только копированием перенести в B1, но и копированием форматов (кисточкой)
2. Попробуй так:
в модуль листа вставь событие


Код:
Private Sub Worksheet_Change(ByVal Target as Range)
Target.Font.ColorIndex = 5
End Sub

Приветствую. Помогите пожалуйста решить задачку.
Есть такой файл Эксель.

Сам файл.
http://ifolder.ru/13826663

Задача такая:
Есть два разных вида столбцов Один выделен желтым другой выделен Оранжевым.
Как можно сделать так, что бы Например Из столбца выделенным желтым.
1 Ячейка
2 Ячейка
И т.далее сколько их там будет
Сравнивалась со столбцами выделенными Оранжевыми
Например:Из желтого столбца
ABCR12555543/DBLUER        S
Надо найти в оранжевом столбце, причем найти надо не по отдельности а именно 100% совпадение. Рядом с кажым артикулом есть Количество.
Если данное значение
ABCR12555543/DBLUER        S
было найдено в Оранжевом столбце то количество надо подставить в Столбец В пути. Если не чего не найдено то ничего и не ставить.

Сравнивать столбцы по отедельности за счет формулы:

Код:
=ЕСЛИ(ЕТЕКСТ(ВПР(B1;A$1:A$14839;1;0))=ИСТИНА;1;0)

Цитата:

Private Sub Worksheet_Change(ByVal Target as Range)
Target.Font.ColorIndex = 5
End Sub



Target - изменяемый диапазон, с которым можно поработать, определив нужное форматирование. Запиши в таком же духе все то форматирование которое у тебя должно быть (шрифт, заливка, и тд).
Типа - отмена переноса форматирования ))

Предложение понятное. Но есть ли что-нибудь по проще?

leoway
проще наверно только если вообще доступ к ячейкам закрыть.
Если пользователь может поставить курсор на ячейку, пусть даже она защищена, то он же сможет нажать Copy. А раз он это нажал, то в буфер уже ушло форматирование, а контролировать буфер через VBA (стирать) нельзя.
Перехватить команду Copy также не получится нормально, если только через перехват клавы и мышки и запуска процедуры копирования только значения - но это сложнее и тяжелее обработка будет команд.

Кхм, появился вопрос.
Как передать данные между двумя формами?
ситуация -
форма1. при ее запуске она получает данные из файла и заносит их в массив, определенный в declarations формы. + в листбокс заносит часть данных.
форма2. редактирование пункта листбокс + нужно взять все данные из данного пункта (которые содержатся в массиве формы1)
вижу только такие решения -
1 - на форме1 создать скрытые метки(текстбоксы) и форма2 при запуске получает из них данные (вариант не подходит, т.к. массив данных Очень большой)
2 - в модуле прописать еще один массив как глобальный, и часть данных сливать туда при запуске формы2 (вариант тоже не лучший, т.к. форм много, массивов тоже, и их размерность различается)

Может, есть решения, когда переменную можно объявить только для двух форм одновременно? или что нибудь подобное.

Добавлено:
Only4You

Код: =ЕСЛИ(ЕОШИБКА(ЕСЛИ(B2=ИНДЕКС(F$2:I$65536;ПОИСКПОЗ(A2;F$2:F$65536;0);2);ЕСЛИ(C2=ИНДЕКС(F$2:I$65536;ПОИСКПОЗ(A2;F$2:F$65536;0);3);ЕСЛИ(D2=ИНДЕКС(F$2:I$65536;ПОИСКПОЗ(A2;F$2:F$65536;0);4);D2);"");""))=ИСТИНА;"";ЕСЛИ(B2=ИНДЕКС(F$2:I$65536;ПОИСКПОЗ(A2;F$2:F$65536;0);2);ЕСЛИ(C2=ИНДЕКС(F$2:I$65536;ПОИСКПОЗ(A2;F$2:F$65536;0);3);ЕСЛИ(D2=ИНДЕКС(F$2:I$65536;ПОИСКПОЗ(A2;F$2:F$65536;0);4);D2);"");""))

V4mp

Цитата:

на ум приходит такая формула.

оффтоп )))) но по этой огромной формуле

[more]Профессор читает лекцию по математике. Пишет на доске сложную формулу, затем говорит "Очевидно, что..." и пишет на доске другую сложную формулу, не имеющую с первой ничего общего. Потом смотрит на доску, задумывается и уходит в лекторскую. Через полчаса выходит оттуда и с довольным видом говорит: "Да, я был прав, это действительно совершенно очевидно".[/more]

наверное очень глупый вопрос, но срочно нужен ответ:
Макросы созданные под 2007 экселем не запускаются на 2003 и ХР. выдает ошибку: can't find project or library выделяя слово "Left" в коде.

Panmop
1. проверь стоят ли ссылки на все объекты в Tools/REFERENCES
2. Попробуй так
x= application.worksheetFunction.Left .....

visual73
Спасибо. Я скорее админ чем кодер.
Временем ограничен, а с VBA знаком слабо. Сейчас никого знакомого близко под рукой нет, а проблему решить нужно.
Программа работает на другой машине, под другим приложением (2007), на 2003 все плохо.
Поэтому скорее может помочь ответ на вопрос "почему так?" Иная версия VBS? может есть конвертеры или патчи? Или это просто проблема переноса файла с одной машины на другую не зависящая от версии офиса? подозреваю все же библиотеки - переносили один единственный xls путь.
/ По теме:
REFERENCES: Missing: Microsoft Calendar Control 11.0
буду искать. никто не поделится?

x= application.worksheetFunction.Left помогло, теперь дебаггер перебежал к SelectAddress. Заменяю на application.worksheetFunction.SelectAddress вот только мне кажется многовато работы предстоит. получается ссылки потерялись?
Не подскажете как восстановить? ОпенОффис кажется порывался сделать автоматически.

Добавлено:
Private Sub UserForm_Activate()
Calendar1.Today
далее тоже выделил Calendar1.Today и ругнулся... потом ругнулся матом и сдох... видимо тот самый календар контрол.

Panmop
ссылка на Календарь по умолчанию не активирована в VBA Excel. Поэтому ее надо задействовать, а точнее его - элемент ActiveX Календарь. Зайди в VBA (Alt+F11) на какую-нибудь UserForm, на Toolbox правой мышью на "Additional Control" и найди там Календарь (Calendar) и задействуй его.
PS да я тож заканчивал другой факультет )

Цитата:

application.worksheetFunction.SelectAddress вот только мне кажется многовато работы предстоит

у мну была та же проблема с функцией mid. ни с того ни с сего она перестала работать) эксэль ругался, что не подключена библиотека.
порылся в инете, там было предложено такое решение -
удалить все файлы *.exd . находятся в папке <....>:\Documents and Settings\<....>\Application Data\Microsoft\Forms\ (подставь только свой системный диск и пользователя).
Мне по крайней мере помогло.

visual73
V4mp
Спасибо, перенес, прикрепил библиотеки - заработало.

Нужно сделать так, что бы вычисления производились по одноименным ячейкам на разных листах. Т.е. нужно сделать в ВБА усложненную функцию формулы

Код: =B1-Лист1!B1

У меня в программе предусмотрена вставка таблиц в виде рисунков
я заменил часть кода и теперь ставляются внедренные таблицы
Код после замены
Word.Selection.PasteSpecial Link:=False, _
DataType:=wdPasteOLEObject, _
Placement:=0, _
DisplayAsIcon:=False
Вопрос: можно ли исправить код так чтобы таблицы вставлялись из буфера обмена как таблицы rtf?

metrim
еще раз подробнее. Не догнал, слишком быстро бегаешь
Лучше с примером.

DataType:=wdPasteOLEObject, _
Какой должен быть тип аргумента вместо wdPasteOLEObject- сейчас это передача в виде связных таблиц
чтобы тип данных был таблицы excel

Цитата:

еще раз подробнее. Не догнал, слишком быстро бегаешь
Лучше с примером.

Ну вот пример: http://www.onlinedisk.ru/file/213697/
Нужно в ячейки столбца С листа "Лист1" поместить пользовательскую функцию написанную в модуле ВБА, делающую то же, что используемая формула

Цитата:

еще раз подробнее. Не догнал, слишком быстро бегаешь
Лучше с примером.

Я купил программу финансовый анализ
там формируется текстовый отчет в Word и в отчет вставляются таблицы из excel
метод судя по всему
PasteSpecial
нужно чтобы таблицы вставлялись в виде таблиц а не объектов excel и не картинок
привожу полный текст листа vba
Private word As Object
Private WordDoc As Object

[more]Function CentimetersToPoints(sm As Single) As Integer
CentimetersToPoints = sm * 29.7
End Function

Sub WordReport()

Dim word As Object, WordDoc As Object
Dim DiagName As String, TableName As String
Dim WPC As Integer, MyFile As String
Dim i As Double, qi As Double, x As Double
Dim z As Double, y As Double, w As Double, fp As Double
Dim PHidd As Double, Sname As String

If TipOtcheta = 1 Then
Sname = "Text"
Else
Sname = "TValue"
End If

Application.GoTo Reference:=("BFPrognoz")
PHidd = ActiveWorkbook.Sheets("Balance").Range("BFPrognoz").Value
ActiveWorkbook.Sheets("Plan").Columns(5 + PHidd).Hidden = True

Application.GoTo Reference:=("Progn1")
If Sheets("Balance").Range("Progn1").Value = 1 Then
If Sheets("Balance").Range("colint").Value + _
Sheets("Balance").Range("BFPrognoz").Value + 2 > 5 Then
qi = 4
GoTo 51
End If
qi = 4
End If
If Sheets("Balance").Range("Progn1").Value = 0 Then
If Sheets("Balance").Range("colint").Value + _
Sheets("Balance").Range("BFPrognoz").Value + 2 > 6 Then
qi = 4
GoTo 51
End If
qi = 4
End If

51
Set word = CreateObject("Word.application")
wdFloatOverText = 1
wdStory = 6

Set WordDoc = word.Documents.Add(, , wdFormatDocument)

word.Visible = True
word.ScreenUpdating = True
Application.ScreenUpdating = True
word.Application.Activate

If ActiveWorkbook.Sheets("Balance").Range("pformat") = 1 Then
With WordDoc.Range(Start:=word.Selection.Start, End:=WordDoc.Content.End).PageSetup
.Orientation = 0
.TopMargin = CentimetersToPoints(1.5)
.BottomMargin = CentimetersToPoints(1.5)
.LeftMargin = CentimetersToPoints(2.5)
.RightMargin = CentimetersToPoints(1)
End With
Else
With WordDoc.Range(Start:=word.Selection.Start, End:=WordDoc.Content.End).PageSetup
.Orientation = 1
.TopMargin = CentimetersToPoints(1.5)
.BottomMargin = CentimetersToPoints(1.5)
.LeftMargin = CentimetersToPoints(2.5)
.RightMargin = CentimetersToPoints(1)
End With
End If

'word.Selection.TypeParagraph
y = 1
x = 1
z = 1

For i = 1 To 1500
If ActiveWorkbook.Sheets(Sname).Cells(i, 1) = "Банкротство (начало)" Then
x = i
End If
If ActiveWorkbook.Sheets(Sname).Cells(i, 1) = "Банкротство (конец)" Then
y = i
End If
If ActiveWorkbook.Sheets(Sname).Cells(i, 1) = "Конец отчета" Then
z = i
End If
Next i

If Report.CheckBox2 = True Then
w = 1
x = z
End If

For i = 6 To x

Select Case ActiveWorkbook.Sheets(Sname).Cells(i, 1)
Case "Заголовок 1"
word.Selection.Style = WordDoc.Styles("Заголовок 1")
word.Selection.TypeText _
Text:=ActiveWorkbook.Sheets(Sname).Cells(i, 5).Text
word.Selection.TypeParagraph
Case "Заголовок 2"
word.Selection.Style = WordDoc.Styles("Заголовок 2")
word.Selection.TypeText _
Text:=ActiveWorkbook.Sheets(Sname).Cells(i, 5).Text
word.Selection.TypeParagraph
Case "Заголовок 3"
word.Selection.Style = WordDoc.Styles("Заголовок 3")
word.Selection.TypeText _
Text:=ActiveWorkbook.Sheets(Sname).Cells(i, 5).Text
word.Selection.TypeParagraph
Case "Альбомная"
wdSectionBreakNextPage = 2
WordDoc.Range(Start:=word.Selection.Start, End:=word.Selection.Start). _
InsertBreak Type:=wdSectionBreakNextPage
word.Selection.Start = word.Selection.Start + 1
With WordDoc.Range(Start:=word.Selection.Start, End:=WordDoc.Content.End).PageSetup
.Orientation = 1
End With
Case "Книжная"
wdSectionBreakNextPage = 2
WordDoc.Range(Start:=word.Selection.Start, End:=word.Selection.Start). _
InsertBreak Type:=wdSectionBreakNextPage
word.Selection.Start = word.Selection.Start + 1
With WordDoc.Range(Start:=word.Selection.Start, End:=WordDoc.Content.End).PageSetup
.Orientation = 0
End With
Case "Диаграмма"

DiagName = ActiveWorkbook.Sheets(Sname).Cells(i, 2)
Sheets(DiagName).Select
ActiveChart.ChartArea.Copy
word.Selection.TypeParagraph

' вставляем диаграмму
word.Selection.PasteSpecial Link:=False, _
DataType:=wdPasteOLEObject, _
Placement:=0, _
DisplayAsIcon:=False
word.Selection.TypeParagraph

Case "Формула"
word.Selection.TypeText _
Text:=ActiveWorkbook.Sheets(Sname).Cells(i, 5).Text
WPC = WordDoc.Paragraphs.Count
word.ActiveDocument.Paragraphs(WPC).Range.Select
With word.Selection.ParagraphFormat
wdAlignParagraphJustify = 1
.Alignment = wdAlignParagraphJustify
.FirstLineIndent = CentimetersToPoints(1#)
End With
With word.Selection
.Font.Italic = True
End With
word.Selection.MoveRight Unit:=1, Count:=1
word.Selection.TypeParagraph
word.ActiveDocument.Paragraphs(WPC + 1).Range.Select
Case "Обычный"
word.Selection.Style = WordDoc.Styles("Обычный")
word.Selection.TypeText _
Text:=ActiveWorkbook.Sheets(Sname).Cells(i, 5).Text
WPC = WordDoc.Paragraphs.Count
word.ActiveDocument.Paragraphs(WPC).Range.Select
With word.Selection.ParagraphFormat
wdAlignParagraphJustify = 3
.Alignment = wdAlignParagraphJustify
.FirstLineIndent = CentimetersToPoints(0.7)
End With
word.Selection.MoveRight Unit:=1, Count:=1
word.Selection.TypeParagraph
word.ActiveDocument.Paragraphs(WPC + 1).Range.Select
With word.Selection.ParagraphFormat
.FirstLineIndent = CentimetersToPoints(0#)
End With
Case "Рисунок"
' наименование таблицы
WPC = WordDoc.Paragraphs.Count
word.ActiveDocument.Paragraphs(WPC).Range.Select
With word.Selection.ParagraphFormat
wdAlignParagraphCenter = 1
.Alignment = wdAlignParagraphCenter
End With
With word.Selection
.Font.Bold = True
End With
TableName = ActiveWorkbook.Sheets(Sname).Cells(i, 2)
word.Selection.TypeText _
Text:=ActiveWorkbook.Sheets(Sname).Cells(i, 5).Text
With word.Selection
.Font.Bold = False
End With
word.Selection.TypeParagraph
' надпись (рисунок №)
word.Selection.TypeParagraph
word.ActiveDocument.Paragraphs(WPC + 1).Range.Select
With word.Selection.ParagraphFormat
wdAlignParagraphRight = 2
.Alignment = wdAlignParagraphRight
End With
TableName = ActiveWorkbook.Sheets(Sname).Cells(i, 2)
word.Selection.TypeText _
Text:=ActiveWorkbook.Sheets(Sname).Cells(i, 4).Text
Application.GoTo Reference:=(TableName)
Selection.Copy
' вставляем картинку ' 4 - формат bmp, 3 - пять периодов максимум
word.Selection.PasteSpecial Link:=False, _
DataType:=wdPasteOLEObject, _
Placement:=0, _
DisplayAsIcon:=False
word.Selection.TypeParagraph
Case "Приложение2"
If Report.CheckBox1 = True Then
On Error GoTo 10
MyFile = ActiveWorkbook.Sheets("Balance").Range("PrilFile").Value
Set Pril = CreateObject("Word.Application")
Pril.Documents.Open Filename:=MyFile, ReadOnly:=True
With Pril
.ActiveDocument.Select
.Selection.Copy
End With
word.Selection.Paste
End If
10
word.Application.Activate
20
Case "Разрыв"
wdPageBreak = 7
word.Selection.InsertBreak Type:=wdPageBreak
End Select

Next i


' в случае отсутствия главы о банкротстве.
If w = 1 Then GoTo 50

For i = y To z

Select Case ActiveWorkbook.Sheets(Sname).Cells(i, 1)
Case "Заголовок 1"
word.Selection.Style = WordDoc.Styles("Заголовок 1")
word.Selection.TypeText _
Text:=ActiveWorkbook.Sheets(Sname).Cells(i, 5).Text
word.Selection.TypeParagraph
Case "Заголовок 2"
word.Selection.Style = WordDoc.Styles("Заголовок 2")
word.Selection.TypeText _
Text:=ActiveWorkbook.Sheets(Sname).Cells(i, 5).Text
word.Selection.TypeParagraph
Case "Заголовок 3"
word.Selection.Style = WordDoc.Styles("Заголовок 3")
word.Selection.TypeText _
Text:=ActiveWorkbook.Sheets(Sname).Cells(i, 5).Text
word.Selection.TypeParagraph
Case "Альбомная"
wdSectionBreakNextPage = 2
WordDoc.Range(Start:=word.Selection.Start, End:=word.Selection.Start). _
InsertBreak Type:=wdSectionBreakNextPage
word.Selection.Start = word.Selection.Start + 1
With WordDoc.Range(Start:=word.Selection.Start, End:=WordDoc.Content.End).PageSetup
.Orientation = 1
End With
Case "Книжная"
wdSectionBreakNextPage = 2
WordDoc.Range(Start:=word.Selection.Start, End:=word.Selection.Start). _
InsertBreak Type:=wdSectionBreakNextPage
word.Selection.Start = word.Selection.Start + 1
With WordDoc.Range(Start:=word.Selection.Start, End:=WordDoc.Content.End).PageSetup
.Orientation = 0
End With
Case "Диаграмма"

DiagName = ActiveWorkbook.Sheets(Sname).Cells(i, 2)
Sheets(DiagName).Select
ActiveChart.ChartArea.Copy
word.Selection.TypeParagraph

' вставляем диаграмму
word.Selection.PasteSpecial Link:=False, _
DataType:=3, _
Placement:=0, _
DisplayAsIcon:=False
word.Selection.TypeParagraph

Case "Формула"
word.Selection.TypeText _
Text:=ActiveWorkbook.Sheets(Sname).Cells(i, 5).Text
WPC = WordDoc.Paragraphs.Count
word.ActiveDocument.Paragraphs(WPC).Range.Select
With word.Selection.ParagraphFormat
wdAlignParagraphJustify = 3
.Alignment = wdAlignParagraphJustify
.FirstLineIndent = CentimetersToPoints(1#)
End With
word.Selection.MoveRight Unit:=1, Count:=1
word.Selection.TypeParagraph
word.ActiveDocument.Paragraphs(WPC + 1).Range.Select
Case "Обычный"
word.Selection.Style = WordDoc.Styles("Обычный")
word.Selection.TypeText _
Text:=ActiveWorkbook.Sheets(Sname).Cells(i, 5).Text
WPC = WordDoc.Paragraphs.Count
word.ActiveDocument.Paragraphs(WPC).Range.Select
With word.Selection.ParagraphFormat
wdAlignParagraphJustify = 3
.Alignment = wdAlignParagraphJustify
.FirstLineIndent = CentimetersToPoints(0.7)
End With
word.Selection.MoveRight Unit:=1, Count:=1
word.Selection.TypeParagraph
word.ActiveDocument.Paragraphs(WPC + 1).Range.Select
With word.Selection.ParagraphFormat
.FirstLineIndent = CentimetersToPoints(0#)
End With
Case "Рисунок"
' наименование таблицы
WPC = WordDoc.Paragraphs.Count
word.ActiveDocument.Paragraphs(WPC).Range.Select
With word.Selection.ParagraphFormat
wdAlignParagraphCenter = 1
.Alignment = wdAlignParagraphCenter
End With
With word.Selection
.Font.Bold = True
End With
TableName = ActiveWorkbook.Sheets(Sname).Cells(i, 2)
word.Selection.TypeText _
Text:=ActiveWorkbook.Sheets(Sname).Cells(i, 5).Text
With word.Selection
.Font.Bold = False
End With
word.Selection.TypeParagraph
' надпись (рисунок №)
word.Selection.TypeParagraph
word.ActiveDocument.Paragraphs(WPC + 1).Range.Select
With word.Selection.ParagraphFormat
wdAlignParagraphRight = 2
.Alignment = wdAlignParagraphRight
End With
TableName = ActiveWorkbook.Sheets(Sname).Cells(i, 2)
word.Selection.TypeText _
Text:=ActiveWorkbook.Sheets(Sname).Cells(i, 4).Text
Application.GoTo Reference:=(TableName)
Selection.Copy
' вставляем картинку ' 4 - формат bmp, 3 - пять периодов максимум
word.Selection.TypeParagraph
word.Selection.PasteSpecial Link:=False, _
DataType:=qi, _
Placement:=0, _
DisplayAsIcon:=False
word.Selection.TypeParagraph
Case "Приложение2"
If Report.CheckBox1 = True Then
On Error GoTo 40
MyFile = ActiveWorkbook.Sheets("Balance").Range("PrilFile").Value
Set Pril = CreateObject("Word.Application")
Pril.Documents.Open Filename:=MyFile, ReadOnly:=True
With Pril
.ActiveDocument.Select
.Selection.Copy
End With
word.Selection.Paste
End If
40
Case "Разрыв"
wdPageBreak = 7
word.Selection.InsertBreak Type:=wdPageBreak
End Select

Next i

50

' осуществляем переход на начало первой страницы

With word.Selection
.GoTo What:=1, Count:=1
End With

wdPageBreak = 7
word.Selection.InsertBreak Type:=wdPageBreak

'первая страница

If ActiveWorkbook.Sheets("Balance").Range("pformat") = 1 Then
fp = 22
Else
fp = 15
End If

WordDoc.Application.Browser.Previous
For i = 1 To fp
word.Selection.TypeParagraph
Next i
With word.Selection
.Style = WordDoc.Styles("Обычный")
.Font.name = "Arial"
.Font.Size = 16
.Font.Bold = True
End With
If TipOtcheta = 1 Then
word.Selection.TypeText Text:="АНАЛИЗ ФИНАНСОВОГО СОСТОЯНИЯ"
Else
word.Selection.TypeText Text:="ОТЧЕТ ОБ ОЦЕНКЕ СТОИМОСТИ"
End If
word.Selection.ParagraphFormat.Alignment = 1
word.Selection.TypeParagraph
word.Selection.TypeText _
Text:=ActiveWorkbook.Sheets(Sname).Cells(3, 5).Text

wdPageBreak = 7
word.Selection.InsertBreak Type:=wdPageBreak

With word.Selection
.GoTo What:=1, Count:=2
End With

' построение оглавления

With WordDoc
.TablesOfContents.Add Range:=word.Selection.Range, RightAlignPageNumbers:= _
True, UseHeadingStyles:=True, UpperHeadingLevel:=1, _
LowerHeadingLevel:=3, IncludePageNumbers:=True, AddedStyles:=""
.TablesOfContents(1).TabLeader = wdTabLeaderDots
.TablesOfContents.Format = wdIndexIndent
End With

' колонтитулы

word.ActiveWindow.ActivePane.View.SeekView = 9

With word.Selection.Font
.Underline = 1
.name = "Arial"
.Size = 8
.ColorIndex = 15
.Bold = True
End With
word.Selection.TypeText _
Text:="Анализ проведен " & ActiveWorkbook.Sheets(Sname).Cells(3, 1).Text & " стр. № "
word.Selection.Fields.Add Range:=word.Selection.Range, Type:=33
word.Selection.ParagraphFormat.Alignment = 2

word.ActiveWindow.ActivePane.View.SeekView = 10

With word.Selection.Font
.Underline = wdUnderlineSingle
.name = "Arial"
.Size = 8
.ColorIndex = 15
.Bold = True
End With
word.Selection.TypeText _
Text:=ActiveWorkbook.Sheets(Sname).Cells(4, 1).Text
word.Selection.ParagraphFormat.Alignment = 2

word.ActiveWindow.ActivePane.View.SeekView = 0

For i = 2 To 14
Sheets(i).Activate
Sheets(i).Range(Cells(2, 1), Cells(2, 1)).Select
Next i

ActiveWorkbook.Sheets("Plan").Columns(5 + PHidd).Hidden = False

On Error Resume Next
word.Documents.Save

On Error Resume Next
word.Application.Activate
On Error Resume Next
WordDoc.Close

Set WordDoc = Nothing
Set Pril = Nothing
Set word = Nothing

ActiveWorkbook.Activate

End Sub

Sub WordReport367()


Dim word As Object, WordDoc As Object
Dim DiagName As String, TableName As String
Dim WPC As Integer, MyFile As String
Dim i As Double, qi As Double, x As Double
Dim z As Double, y As Double, w As Double, fp As Double


Application.GoTo Reference:=("Progn1")
If Sheets("Balance").Range("Progn1").Value = 1 Then
If Sheets("Balance").Range("colint").Value + _
Sheets("Balance").Range("BFPrognoz").Value + 2 > 5 Then
qi = 4
GoTo 51
End If
qi = 3
End If
If Sheets("Balance").Range("Progn1").Value = 0 Then
If Sheets("Balance").Range("colint").Value + _
Sheets("Balance").Range("BFPrognoz").Value + 2 > 6 Then
qi = 4
GoTo 51
End If
qi = 3
End If

51
Set word = CreateObject("Word.application")
wdFloatOverText = 1
wdStory = 6

Set WordDoc = word.Documents.Add(, , wdFormatDocument)

word.Visible = True
word.ScreenUpdating = True
Application.ScreenUpdating = True
word.Application.Activate

If ActiveWorkbook.Sheets("Balance").Range("pformat") = 1 Then
With WordDoc.Range(Start:=word.Selection.Start, End:=WordDoc.Content.End).PageSetup
.Orientation = 0
.TopMargin = CentimetersToPoints(1.5)
.BottomMargin = CentimetersToPoints(1.5)
.LeftMargin = CentimetersToPoints(2.5)
.RightMargin = CentimetersToPoints(1)
End With
Else
With WordDoc.Range(Start:=word.Selection.Start, End:=WordDoc.Content.End).PageSetup
.Orientation = 1
.TopMargin = CentimetersToPoints(2.5)
.BottomMargin = CentimetersToPoints(1)
.LeftMargin = CentimetersToPoints(1.5)
.RightMargin = CentimetersToPoints(1.5)
End With
End If

'word.Selection.TypeParagraph

For i = 1 To 1500
If ActiveWorkbook.Sheets("Text367").Cells(i, 1) = "Конец отчета" Then
x = i
End If
Next i

For i = 6 To x

Select Case ActiveWorkbook.Sheets("Text367").Cells(i, 1)
Case "Заголовок 1"
word.Selection.Style = WordDoc.Styles("Заголовок 1")
word.Selection.TypeText _
Text:=ActiveWorkbook.Sheets("Text367").Cells(i, 4).Text
word.Selection.TypeParagraph
Case "Заголовок 2"
word.Selection.Style = WordDoc.Styles("Заголовок 2")
word.Selection.TypeText _
Text:=ActiveWorkbook.Sheets("Text367").Cells(i, 4).Text
word.Selection.TypeParagraph
Case "Заголовок 3"
word.Selection.Style = WordDoc.Styles("Заголовок 3")
word.Selection.TypeText _
Text:=ActiveWorkbook.Sheets("Text367").Cells(i, 4).Text
word.Selection.TypeParagraph
Case "Альбомная"
wdSectionBreakNextPage = 2
WordDoc.Range(Start:=word.Selection.Start, End:=word.Selection.Start). _
InsertBreak Type:=wdSectionBreakNextPage
word.Selection.Start = word.Selection.Start + 1
With WordDoc.Range(Start:=word.Selection.Start, End:=WordDoc.Content.End).PageSetup
.Orientation = 1
End With
Case "Книжная"
wdSectionBreakNextPage = 2
WordDoc.Range(Start:=word.Selection.Start, End:=word.Selection.Start). _
InsertBreak Type:=wdSectionBreakNextPage
word.Selection.Start = word.Selection.Start + 1
With WordDoc.Range(Start:=word.Selection.Start, End:=WordDoc.Content.End).PageSetup
.Orientation = 0
End With
Case "Диаграмма"

DiagName = ActiveWorkbook.Sheets("Text367").Cells(i, 2)
Sheets(DiagName).Select
ActiveChart.ChartArea.Copy
word.Selection.TypeParagraph

' вставляем диаграмму
word.Selection.PasteSpecial Link:=False, _
DataType:=3, _
Placement:=0, _
DisplayAsIcon:=False
word.Selection.TypeParagraph

Case "Формула"
word.Selection.TypeText _
Text:=ActiveWorkbook.Sheets("Text367").Cells(i, 4).Text
WPC = WordDoc.Paragraphs.Count
word.ActiveDocument.Paragraphs(WPC).Range.Select
With word.Selection.ParagraphFormat
wdAlignParagraphJustify = 1
.Alignment = wdAlignParagraphJustify
.FirstLineIndent = CentimetersToPoints(1#)
End With
With word.Selection
.Font.Italic = True
End With
word.Selection.MoveRight Unit:=1, Count:=1
word.Selection.TypeParagraph
word.ActiveDocument.Paragraphs(WPC + 1).Range.Select
Case "Обычный"
word.Selection.Style = WordDoc.Styles("Обычный")
word.Selection.TypeText _
Text:=ActiveWorkbook.Sheets("Text367").Cells(i, 4).Text
WPC = WordDoc.Paragraphs.Count
word.ActiveDocument.Paragraphs(WPC).Range.Select
With word.Selection.ParagraphFormat
wdAlignParagraphJustify = 3
.Alignment = wdAlignParagraphJustify
.FirstLineIndent = CentimetersToPoints(0.7)
End With
word.Selection.MoveRight Unit:=1, Count:=1
word.Selection.TypeParagraph
word.ActiveDocument.Paragraphs(WPC + 1).Range.Select
With word.Selection.ParagraphFormat
.FirstLineIndent = CentimetersToPoints(0#)
End With
Case "Рисунок"
' наименование таблицы
WPC = WordDoc.Paragraphs.Count
word.ActiveDocument.Paragraphs(WPC).Range.Select
With word.Selection.ParagraphFormat
wdAlignParagraphCenter = 1
.Alignment = wdAlignParagraphCenter
End With
With word.Selection
.Font.Bold = True
End With
TableName = ActiveWorkbook.Sheets("Text367").Cells(i, 2)
word.Selection.TypeText _
Text:=ActiveWorkbook.Sheets("Text367").Cells(i, 4).Text
With word.Selection
.Font.Bold = False
End With
word.Selection.TypeParagraph
' надпись (рисунок №)
word.Selection.TypeParagraph
word.ActiveDocument.Paragraphs(WPC + 1).Range.Select
With word.Selection.ParagraphFormat
wdAlignParagraphRight = 2
.Alignment = wdAlignParagraphRight
End With
TableName = ActiveWorkbook.Sheets("Text367").Cells(i, 2)
word.Selection.TypeText _
Text:=ActiveWorkbook.Sheets("Text367").Cells(i, 4).Text
Application.GoTo Reference:=(TableName)
Selection.Copy
' вставляем картинку ' 4 - формат bmp, 3 - пять периодов максимум
word.Selection.TypeParagraph

word.Selection.TypeParagraph
Case "Приложение2"
If Report.CheckBox1 = True Then
On Error GoTo 10
MyFile = ActiveWorkbook.Sheets("Balance").Range("PrilFile").Value
Set Pril = CreateObject("Word.Application")
Pril.Documents.Open Filename:=MyFile, ReadOnly:=True
With Pril
.ActiveDocument.Select
.Selection.Copy
End With
word.Selection.Paste
End If
GoTo 20
10
MsgBox ("Файл приложения к отчету выбран некорректно. Отчет будет построен без приложения")
20
Case "Разрыв"
wdPageBreak = 7
word.Selection.InsertBreak Type:=wdPageBreak
End Select

Next i

' осуществляем переход на начало первой страницы

With word.Selection
.GoTo What:=1, Count:=1
End With

wdPageBreak = 7
word.Selection.InsertBreak Type:=wdPageBreak

'первая страница

If ActiveWorkbook.Sheets("Balance").Range("pformat") = 1 Then
fp = 22
Else
fp = 15
End If

WordDoc.Application.Browser.Previous
For i = 1 To fp
word.Selection.TypeParagraph
Next i
With word.Selection
.Style = WordDoc.Styles("Обычный")
.Font.name = "Arial"
.Font.Size = 16
.Font.Bold = True
End With
word.Selection.TypeText Text:="АНАЛИЗ ФИНАНСОВОГО СОСТОЯНИЯ"
word.Selection.ParagraphFormat.Alignment = 1
word.Selection.TypeParagraph
word.Selection.TypeText _
Text:=ActiveWorkbook.Sheets("Text367").Cells(3, 4).Text

wdPageBreak = 7
word.Selection.InsertBreak Type:=wdPageBreak

With word.Selection
.GoTo What:=1, Count:=2
End With

' построение оглавления

With WordDoc
.TablesOfContents.Add Range:=word.Selection.Range, RightAlignPageNumbers:= _
True, UseHeadingStyles:=True, UpperHeadingLevel:=1, _
LowerHeadingLevel:=3, IncludePageNumbers:=True, AddedStyles:=""
.TablesOfContents(1).TabLeader = wdTabLeaderDots
.TablesOfContents.Format = wdIndexIndent
End With

' колонтитулы

word.ActiveWindow.ActivePane.View.SeekView = 9

With word.Selection.Font
.Underline = 1
.name = "Arial"
.Size = 8
.ColorIndex = 15
.Bold = True
End With
word.Selection.TypeText _
Text:="Анализ проведен " & ActiveWorkbook.Sheets("Text367").Cells(3, 1).Text & " стр. № "
word.Selection.Fields.Add Range:=word.Selection.Range, Type:=33
word.Selection.ParagraphFormat.Alignment = 2

word.ActiveWindow.ActivePane.View.SeekView = 10

With word.Selection.Font
.Underline = wdUnderlineSingle
.name = "Arial"
.Size = 8
.ColorIndex = 15
.Bold = True
End With
word.Selection.TypeText _
Text:=ActiveWorkbook.Sheets("Text367").Cells(4, 1).Text
word.Selection.ParagraphFormat.Alignment = 2

word.ActiveWindow.ActivePane.View.SeekView = 0

For i = 2 To 14
Sheets(i).Activate
Sheets(i).Range(Cells(2, 1), Cells(2, 1)).Select
Next i

On Error Resume Next
word.Documents.Save
On Error Resume Next
WordDoc.Close

Set WordDoc = Nothing
Set Pril = Nothing
Set word = Nothing

ActiveWorkbook.Activate

End Sub

[/more]

metrim
пожалуйста, функция делает тоже что и формула

Function Фунтик(x, ИмяЛиста)
Фунтик = x - Range(ИмяЛиста & "!" & x.Address)
End Function


yuriisv
вот ты выдал! Я вообще то не к тебе обращался, если что. Такие перлы лучше прятать под тэг [more]

Цитата:

metrim
пожалуйста, функция делает тоже что и формула

Function Фунтик(x, y)
Фунтик = x - y
End Function

Да нет, все несколько сложнее.

надо функцию вида =зероинг(B2)


Код: Function Фунтик(ячейка)
Другой_лист = Лист с данными о "фоне"
зероинг = Текущий_лист!(ячейка) - Другой_лист!(ячейка)
End Function

metrim
я уже догадался и исправил . Пойдет?
xlCalculationAutomatic - автоматический пересчет формул. Отключают при выполнении кода чтобы не тратить ресурсы ПК на пересчет.

Цитата:

я уже догадался и исправил . Пойдет?

Да, именно это

Цитата:

xlCalculationAutomatic - автоматический пересчет формул. Отключают при выполнении кода чтобы не тратить ресурсы ПК на пересчет.

Т.е. что мне надо сделать, что бы пользовательские функции в ячейках пересчитывались автоматически? У меня эти функции в качестве параметров исплользуют значения ячеек (передаются параметрами) + константы. Так вот, когда меняю константы - значения ячеек - не пересчитываются "на лету", приходится их обновлять вручную

metrim
по умолчанию все пересчитывается, и стоит значение xlCalculationAutomatic.
Если мы начинаем что-то вычислять с помощью VBA, то вначале кода пишем
Application.Calculation = xlCalculationManual
а в конце кода пишем
Application.Calculation = xlCalculationAutomatic

Кто редактировал текст на кнопках Ribbon?

Office 2007 Custom UI Editor - сразу после ввода русский текст конвертится в крякозябры и так и сохраняется.

Здравствуйте, помогите немного разобраться со следующим.
В проекте vba создал класс Item_Reestr_of_inkassation с полями

Private RegNumber As Long
Private DateOfInkassation As Date
Private Sum_ours_card As Long
Private Sum_another_card As Long
Private Sum_all_card As Long
Private isValidNumber As Boolean
Private wasPrint As Boolean
Private SheetName As String

Public Sub Init(Optional ByVal inRegNumber As Long = 100000, _
Optional ByVal inDateOfInkassation As Date = #1/1/2001#, _
Optional ByVal inSum_ours_card As Long = 0, _
Optional ByVal inSum_another_card As Long = 0, _
Optional ByVal inSum_all_card As Long = 0)
RegNumber = inRegNumber
DateOfInkassation = CDate(inDateOfInkassation)
Debug.Print CDate(inDateOfInkassation)
Sum_ours_card = inSum_ours_card
Sum_another_card = inSum_another_card
Sum_all_card = inSum_all_card
wasPrint = False
isValidNumber = False
End

Далее в одном из модулей делаю следующее несколько раз с разнами параметрами для Init

Dim Coll As New Collection
Dim Reestr_ As New Item_Reestr_of_inkassation
Reestr_.Init CLng(Number), _
CDate(strDate), _
Val(ConvertCashToDouble(Sum_owr)), _
Val(ConvertCashToDouble(Sum_another)), _
Val(ConvertCashToDouble(Sum_all))
Coll.Add Reestr_

Вопрос в следующем: когда объект добавляется в коллекцию то предыдущие значения, т.е. элементы добавленные ранее получают значение как последний добавленный объект.
Почему? Как сделать чтобы сохранялись предыдущие значения без изменения?

Здравствуйте. В результате вычислений получаем переменную. Возможно ли, не вводя данные в ячейку, присвоить зеначение переменной в буфер обмена таким образом, что бы, находясь в любом текстовом редвкторе и используя комбинацию клавиш Ctrl + V, смог вставить это значение.

ferias
подключите в Tools- Reference библиотеку "Microsoft Forms 2.0 object library"
и попробуйте такой код:

Код:
Sub MyTestPutToClipBoard()
Dim MyDataObj As New DataObject
Dim sTest1 As String
MyDataObj.Clear
sTest1 = "This Text will be copied to clipboard"
MyDataObj.SetText sTest1
MyDataObj.PutInClipboard
End Sub