» Excel VBA (часть 3)

asbo
А если столбец B - денежный (р.) , а D - текстовый, то в D после первого копирования получается $1.00, после второго правильно, а если денежный - евро или фунт, то так и остается текстовым

smirnvlad
ОК. Чуть попозжа попробую. У меня файл на другом компе.

TXP
CBut1.Enabled = CBool(Range("A1").Value = 0)

Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Address = "L4" Then
CBut1.Enabled = CBool(Range("L4").Value = 0)
End If
End Sub
Не работает(
в ячейке "L4" находится формула "=ЕСЛИ(СУММ(БП!AL13:AM32)=0;0;1)" - сумма контрольных показателей. В идеале в зависимости от значения ячейки элемент управления (Кнопка CBut1) должен менять свойство Enabled, на деле свойство меняется если значение ячейки L4 меняется вручную.

Подскажите что не так с кодом. Бьет ошибку 4605 на этапе выполнения. Что то связанное с добавлением данных в ворд, так как выбивает на втором Selection. При этом ворд нормально запускается...

Sub Zamena()
Dim WordApp As Object
Dim Data As Range
Dim Doljnost As String
Dim Fio As String
Dim Predpriatie As String
Dim SaveAsName As String
Dim Record As Integer, i As Integer

Set WordApp = CreateObject("Word.Application")
Set Data = Sheets(" Лист1").Range("A1")
For i = 2 To 10
Doljnost = Data.Cells(i, 2).Value
Fio = Data.Cells(i, 3).Value
Predpriatie = Data.Cells(i, 4).Value
SaveAsName = ThisWorkbook.Path & "\" & Doljnost & " .doc"
With WordApp
.Documents.Add Template:="Normal", NewTemplate:=False, DocumentType:=0
With .Selection
.PasteExcelTable False, False, False
.Font.Bold = wdToggle
.ParagraphFormat.Alignment = wdAlignParagraphRight
.TypeText Text:=Doljnost
End With
End With
WordApp.ActiveDocument.SaveAs Filename:=SaveAsName

Next i
WordApp.Quit
Set WordApp = Nothing


End Sub

TXP, не возникает событие Worksheet_Change, поскольку изменение происходит на другом листе - БП.

Самый простой вариант - замодифицировать процедуру примерно до такого варианта:

Код: Sub Zamena()
Dim WordApp As Object
Dim Data As Range
Dim Doljnost As String
Dim Fio As String
Dim Predpriatie As String
Dim SaveAsName As String
Dim Record As Integer, i As Integer

On Error GoTo Err

Set WordApp = CreateObject("Word.Application")
Set Data = Sheets(" Лист1").Range("A1")
For i = 2 To 10
Doljnost = Data.Cells(i, 2).Value
Fio = Data.Cells(i, 3).Value
Predpriatie = Data.Cells(i, 4).Value
SaveAsName = ThisWorkbook.Path & "\" & Doljnost & " .doc"
With WordApp
.Documents.Add Template:="Normal", NewTemplate:=False, DocumentType:=0
With .Selection
.PasteExcelTable False, False, False
.Font.Bold = wdToggle
.ParagraphFormat.Alignment = wdAlignParagraphRight
.TypeText Text:=Doljnost
End With
End With
WordApp.ActiveDocument.SaveAs Filename:=SaveAsName

Next i
WordApp.Quit
Set WordApp = Nothing
Exit Sub
Err:
DoEvents
Resume
End Sub

Lorienara, что-то я второго Selection в коде не обнаружил...
- Может из-за того что надо что-то Select?
- Да и в буфере обмена что-то должно быть (PasteExcelTable )
- Устанавливаем Data, как единственную ячейку (Set Data = Sheets(" Лист1").Range("A1")), а потом из нее еще что-то выгребаем (Data.Cells(i, 2)) ...


Добавлено:
ZlydenGL
Цитата:

потому что адрес надо вводить "в баксах"

А хоть в фунтах. Событие все равно не возникнет...

Спасибо за внимание к проблемке)
Сделал все как Вы сказали - ну что то не возвращаетсяч оно к ошибке желтым выделяет Resume и все(

TXP, а, если на перерасчет, тогда так:

Код: Private Sub Worksheet_Calculate()
CBut1.Enabled = CBool(Range("A1").Value = 0)
End Sub

2 asbo
Имелось в виду второй объект Selection.
Спасибо если ничего не поможем и таким путем тоже пойдем.

2 ZlydenGL

Ой, нашлось - экселька отказывается сохранять мой файлик вордовский - гляньте опытным взором где там обшипка в коде

WordApp.ActiveDocument.SaveAs Filename:=SaveAsName

PastExelTable - это я от безысходности хаписал вордом макрос и попытлся его еще добавить в свой собственный- уже удалил ничего не поменялось)

Закрывать документ после сохранения надо.

Бьет ошибку - любезно подсказано ZlydenGL на WordApp.ActiveDocument.SaveAs Filename:=SaveAsName.
Но я наверное заработался сегодня - не могу понять где в этом небольшом коде ошибка.

Lorienara, кажется разобрался. Имя для сохранения задается только один раз, но созданные документы НЕ закрываются после завершения цикла I. Соответственно если есть документ с тем же именем И он открыт - то сохранить еще один документ с тем же именем не удастся. Либо корректируй ТЗ, либо закрывай документы Word после сохранения, либо в конец переменной SaveAsName дописывай I что ли...

Lorienara
Я что-то не вкурю - документ в цикле десять раз создается и каждый созданный сохраняется через SaveAs под одним и тем же именем?

Внимательно код посмотрел, - бред голимый какой-то... Вы бы на пальцах объяснили, чего надо-то?

Я эту версию проверил - не она, сразу после этой строчки указатель перепрыгивает на Err - ну и на Resume возвращаетсяна эту строчку, я даже на всякий случай документ перенес так чтобы русских букв не было в названии папки , пока не помогает(

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

Имя файла под которым сохраняется дока не пустое
Doljnost = Data.Cells(i, 2).Value

на листе 1 даные забиты во в тором столбце?

В чем проблема по F8 пройтись по всей процедуре и не посмотреть где именно выскакивает ошибка и какие именно значения имеют переменные, в частности Doljnost. не надо тупо вызывать всю процедуру целиком.

Lorienara
Range("A24:C28"):
Должность Имя Предприятие

Спасибо огромное asbo,KF121,ZlydenGL

Yаконец, то стали сохраняться документы с данными. Ничего не менял, все пошло после того как закрыл и открыл заново c исправлениями )))

Sub Zamena()
Dim WordApp As Object
Dim Data As Range, message As String
Dim Doljnost As String
Dim Fio As String
Dim Predpriatie As String
Dim SaveAsName As String
Dim Record As Integer
Dim i As Integer
Set WordApp = CreateObject("Word.Application")
Set Data = Sheets("Лист1").Range("A1")
For i = 2 To 3
Doljnost = Data.Cells(i, 2).Value
Fio = Data.Cells(i, 3).Value
Predpriatie = Data.Cells(i, 4).Value
SaveAsName = ThisWorkbook.Path & "\" & Doljnost & " .doc"
With WordApp
.Documents.Add
With .Selection
.Font.Bold = wdToggle
.ParagraphFormat.Alignment = wdAlignParagraphRight
.TypeText Text:=Doljnost
End With
End With

Next i
WordApp.Quit
Set WordApp = Nothing

End Sub

Вот в таком виде заработало нормально. Там еще вопросы с форматиорванием будут, но это ерунда - справляюсь наверное. Еще раз спасибо за то, что указали направления в которых нужно работать.

в вашем последнем коде отсутсувет сохранение, нет сохранения - нет ошибки, хорошее решение

Lorienara, Ой, не лги! Царю лжешь :)

"Стали сохраняться" - процедуры сохранения нет.
Ексель не знает wdAlignParagraphRight .

2 asbo Царю батюшке как можно)

2 KF121 не, надо разобраться почему это не сохраняется как дОлжно.
Я просто в шоке. Но блин программка работает ( просто стало предлагать сохранить документ) - хотя действительно случайно удалил сторчку с сохранением. Чапай будет думать.

Припозднился :)

Так что же? Получается, что метод Range("что_то_там").Cells(n, m) работает как Offset(n - 1, m - 1), даже если в диапазоне одна-единственная ячейка? И это при том, что Cells.Count = 1 ...

Я тоже очень удивился этому - но скелет программы слизан у Джона Уокенбаха. Так что я решил попробовать - работает, но тоже удивился. Мое скромное мнение - Range("что_то_там").Cells(n, m) - просто для краткости взято как Data. Ну а используется да Offset метод. К сожалению это понимание не приблежает к решению вопроса - почему не сохраняется нормально методом SaveAs.

Lorienara
Я же привел выше рабочий код. Все сохраняется, как положено...

Нууу..все попробовал - все стреляет)

Подскажите в какую сторону копать для решения проблемы.
Есть массив из неповторяющихся чисел (все больше 0), упорядоченный по-возрастанию.
Пример: [1 2 3 5 7 9 10 11 12 19 20].
Можно заметить что присутствуют последовательности чисел где разница между 2 смежными числами = 1. (1-3,9-12, 19-20). Надо вычислить такие последовательности и вывести массив в таком формате
1 3
5
7
9 12
19 20

(На каждой строке - либо 1 число, либо начало и конец последовательности)

Dmitriy05
Раскомментировать или Rem-1, или Rem-2, т.е. что-то одно...

Код:
Sub sb_SerChk()
Dim i%, iLB%, iUB%, iDif%
Dim bPre As Boolean, bDif As Boolean
Dim sTxt$, sSfx$(-1 To 1)
Dim vArr()

vArr = Array(1, 2, 3, 5, 7, 9, 10, 11, 12, 19, 20, 23)
iDif = 1
sSfx(True) = " - ": sSfx(False) = vbCr:

iLB = LBound(vArr)
Rem-1 iUB = UBound(vArr) '

Rem-2 iUB = UBound(vArr) + 1
Rem-2 ReDim Preserve vArr(iUB)
Rem-2 vArr(iUB) = vArr(iUB) * 2 + iDif

bDif = False
bPre = False

For i = iLB + 1 To iUB
bDif = ((vArr(i) - vArr(i - 1)) = iDif)
If bDif Xor bPre Then
bPre = bDif
sTxt = sTxt & vArr(i - 1) & sSfx(bDif)
End If
Next
Rem-1 If bPre Then sTxt = sTxt & vArr(i - 1) & sSfx(False)
Debug.Print sTxt
End Sub

Dmitriy05
Вот попроще вариант

Код:
vArr = Array(1, 2, 3, 5, 7, 9, 10, 11, 12, 19, 20, 23)
If vArr(1) - vArr(0) = 1 Then t = vArr(0) Else t = vArr(0) & vbCr
For i = 1 To UBound(vArr) - 1
If vArr(i) - vArr(i - 1) = 1 And vArr(i + 1) - vArr(i) <> 1 Then t = t & " " & vArr(i) & vbCr
If vArr(i) - vArr(i - 1) <> 1 And vArr(i + 1) - vArr(i) <> 1 Then t = t & vArr(i) & vbCr
If vArr(i) - vArr(i - 1) <> 1 And vArr(i + 1) - vArr(i) = 1 Then t = t & vArr(i)
Next
If vArr(i) - vArr(i - 1) = 1 Then t = t & " " & vArr(i) Else t = t & vArr(i)
MsgBox t

aidomars, сам себя не похвалишь... :) Чем проще-то?

asbo? а просто сравниваются два рядомстоящих числа