» Excel VBA (часть 2)

GARRYGOR

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

nick7inc

Цитата:

Можно при помощи стандартных операторов бейсика:
Instr()
Mid$()

Ищем начало, конец, а потом вырезаем нужную часть строки.
Добавлено:
Только не надо забывать, что восклицательный знак, по которому мы ищем, может быть частью имени: ='!A'!B2 Лучше поискать по '!, а если не найдено, то конец имени листа определяем по !. Или просто находим последный !.

Логичнее при разборе InStrRev использовать

Gavrik

Цитата:

Есть ячейка с ссылкой на другой лист "=Лист1!А1", как из VBA получить имя этого листа?

А в случаях подобных
Код: =Лист2!B24+Лист3!C10

ferias
Можно обойтись и без VBA.
Используй расширенный фильтр. Критерий для него: поле - название, используемое для заголовка кодов продуктов, на клетку ниже и правее используешь функцию ПОИСКПОЗ, где задаёшь параметрами первый код продукта на листе Menu и Eliminar. Выполняешь расширенный фильтр и получаешь в Menu выборку соответствующую Eliminar. После чего и удаляешь

Troitsky

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

Можно ли как-нибудь оптимизировать данный макрос?
[more]
Attribute VB_Name = "Module1"
Public Function VerifyFile(FileName$) As Boolean
' Проверка - существует ли указанный файл
On Error Resume Next
' Файл открывается как входной, последовательный
Open FileName$ For Input As #1
If Err Then ' Ошибка при открытии - нет файла
VerifyFile = False
Else
VerifyFile = True: Close #1
End If
End Function

Sub dgs()
Dim Msg, Style, Title, Help, Ctxt, Response, MyString
Dim fn, nfn, TEMP(100), tst, lfn, lcfr As String
Dim t1xt
Dim TempPos(10), strF, i, j, k, nuklpos, pogrpos, aktpos, perpos, l, filenum, pr As Integer
Dim r As Range
Dim nuklvst As Boolean
strF = 0
TempPos(1) = 1
Msg = "Новый или продолжать? Да - новый. Нет - продолжить."
fn = Application.GetOpenFilename("RPT Files (*.rpt),*.rpt", , "Открытие документа *.rpt")
If fn = False Then
Help = "DEMO.HLP" ' Define Help file
Ctxt = 1000
Response = MsgBox("Вы не выбрали файл", vbOKOnly, "Открытие файла", Help, Ctxt)
Exit Sub
End If
filenum = CInt(Mid(fn, InStrRev(fn, "\", , vbTextCompare) + 1, (InStrRev(fn, ".", , vbTextCompare)) - (InStrRev(fn, "\", , vbTextCompare) + 1)))
Style = vbYesNo
Help = "DEMO.HLP" ' Define Help file
Ctxt = 1000
Response = MsgBox(Msg, Style, Title, Help, Ctxt)
If Response = vbYes Then ' User chose Yes.
' Perform some action.
Range("A1").Select
ActiveCell.FormulaR1C1 = "Номер"
Range("B1").Select
ActiveCell.FormulaR1C1 = "Время начала измерения"
Range("C1").Select
ActiveCell.FormulaR1C1 = "T изм"
Range("D1").Select
ActiveCell.FormulaR1C1 = "Среднее время"
Range("E1").Select
ActiveCell.FormulaR1C1 = "Час"
Rows("1:1").Select
Selection.Locked = False
Selection.FormulaHidden = False

Columns("D:E").Select
With Selection.Font
.Name = "Arial CYR"
.FontStyle = "обычный"
.Size = 10
.Strikethrough = False
.Superscript = False
.Subscript = False
.OutlineFont = False
.Shadow = False
.Underline = xlUnderlineStyleNone
.ColorIndex = 10
End With

Close #1
Open fn For Input Access Read Shared As #1 'открытие файла
Do While Not (EOF(1)) 'пока не конец файла (обращение к файлу по номеру)
Line Input #1, TEMP(strF + 1) 'Ввод данных в переменную TEMP без chr(10)&chr(13)
LTrim (RTrim(TEMP(strF + 1)))
strF = strF + 1 'Переменная для подсчета числа строк
Loop 'Окончание цикла для подсчета строк
Close #1 'Закрытие файла
Range("B3").Select
ActiveCell.FormulaR1C1 = Trim(Mid(TEMP(4), 23, 18))

Columns("B").Select
ActiveCell.Name = "rrrrr"
Set r = Range("rrrrr")
i = CInt(Mid(CStr(r.Columns.End(xlDown).Address), InStrRev(CStr(r.Columns.End(xlDown).Address), "$", , vbTextCompare) + 1, 1))

Range("A" + CStr(i + 1)).Select
ActiveCell.FormulaR1C1 = CStr(CInt(Mid(fn, InStrRev(fn, "\", , vbTextCompare) + 1, (InStrRev(fn, ".", , vbTextCompare)) - (InStrRev(fn, "\", , vbTextCompare) + 1))))

Range("B" + CStr(i + 1)).Select
ActiveCell.FormulaR1C1 = Trim(Mid(TEMP(4), 23, 18))
Selection.NumberFormat = "dd/mm/yy hh:mm;@"
Range("B" + CStr(i)).Select
Selection.NumberFormat = "dd/mm/yy hh:mm;@"
Columns("B:B").Select
Selection.NumberFormat = "dd/mm/yy hh:mm;@"
Columns("C:C").Select
Selection.NumberFormat = "0.00"
Columns("D:D").Select
Selection.NumberFormat = "dd/mm/yy hh:mm;@"
Columns("E:E").Select
Selection.NumberFormat = "0.00"


strF = strF - 1
Range("C" + CStr(i + 1)).Select
ActiveCell.FormulaR1C1 = CStr(Mid(TEMP(strF), InStrRev(TEMP(strF), ",", , vbTextCompare) + 1, InStrRev(TEMP(strF), ".", , vbTextCompare) + 2))

Range("D" + CStr(i + 1)).Select
tst = "=" + CStr("B" + CStr(i + 1) + "+C" + CStr(i + 1) + "/3600/24/2")

ActiveCell.Formula = "=" + CStr("B" + CStr(i + 1) + "+C" + CStr(i + 1) + "/3600/24/2")
Range("E" + CStr(i + 1)).Select
tst = "=(D" + CStr(i + 1) + "-B$3)*24"
ActiveCell.Formula = "=(D" + CStr(i + 1) + "-B$3)*24"
Cells(1, 6).Value = Mid(TEMP(8), 1, InStr(1, TEMP(8), " ", vbTextCompare) - 1)

nuklpos = InStr(1, Trim(TEMP(6)), "Н", vbTextCompare)
aktpos = InStr(1, Trim(TEMP(6)), "А", vbTextCompare) + 1
pogrpos = InStr(aktpos, Trim(TEMP(6)), "П", vbTextCompare)
perpos = InStr(1, Trim(TEMP(6)), "П", vbTextCompare) - 5
k = 6
For j = 8 To 256
If Trim(TEMP(j)) = "" Then Exit For
If Trim(Mid(Trim(TEMP(j)), aktpos, 2)) <> "" Then

Range(Cells(i + 1, k), Cells(i + 1, k)).Select
ActiveCell.Formula = Trim(Mid(Trim(TEMP(j)), aktpos, pogrpos - aktpos))
Range(Cells(1, k), Cells(1, k)).Select
ActiveCell.Formula = Mid(Trim(TEMP(j)), 1, InStr(1, Trim(TEMP(j)), " ", vbTextCompare) - 1)
If (Trim(Mid(Trim(TEMP(j)), perpos, aktpos - perpos)) <> "") Then
Range(Cells(2, k), Cells(2, k)).Select
ActiveCell.Formula = Trim(Mid(Trim(TEMP(j)), perpos, aktpos - perpos))
End If
k = k + 1
End If
Next j
label1:

lensl = InStrRev(fn, "\", , vbTextCompare) + 1
lendot = InStr(InStrRev(fn, "\", , vbTextCompare), fn, ".", vbTextCompare)
fnum = CInt(Mid(fn, lensl, lendot - lensl)) + 1
zerolen = lendot - 1 - lensl - Len(CStr(fnum))
'For j = 1 To zerolen
'nfn = nfn + "0"
'Next j
'nfn = nfn + CStr(fnum)
'nfn = nfn + ".RPT"
'nfn = Mid(fn, 1, InStrRev(fn, "\", , vbTextCompare) + 1) + nfn
'fn = nfn

filenum = CInt(Mid(fn, lensl, lendot - lensl)) + 1
lfn = lendot - lensl
'Range(Cells(i + 1, 1), Cells(i + 1, 1)).Select

lcfr = Len(CStr(filenum))
lfn = lendot - lensl - Len(CStr(fnum))
nfn = Mid(fn, 1, InStrRev(fn, "\", , vbTextCompare))
If lfn <> 0 Then
For j = 1 To lfn
nfn = nfn + "0"
Next j
End If
nfn = nfn + CStr(filenum) + ".rpt"
fn = nfn

i = i + 1
FileName$ = fn

If (VerifyFile(FileName$) = False) Then GoTo label2
If (VerifyFile(FileName$)) Then
strF = 0
Open fn For Input Access Read Shared As #1 'открытие файла
Do While Not (EOF(1)) 'пока не конец файла (обращение к файлу по номеру)
Line Input #1, TEMP(strF + 1) 'Ввод данных в переменную TEMP без chr(10)&chr(13)
LTrim (RTrim(TEMP(strF + 1)))
strF = strF + 1 'Переменная для подсчета числа строк
Loop 'Окончание цикла для подсчета строк
Close #1 'Закрытие файла
nuklpos = InStr(1, Trim(TEMP(6)), "Н", vbTextCompare)
aktpos = InStr(1, Trim(TEMP(6)), "А", vbTextCompare) + 1
pogrpos = InStr(aktpos, Trim(TEMP(6)), "П", vbTextCompare) - (InStr(aktpos, Trim(TEMP(6)), "П", vbTextCompare) - InStr(aktpos, Trim(TEMP(6)), ",", vbTextCompare))

Range("A" + CStr(i + 1)).Select
ActiveCell.FormulaR1C1 = CStr(CInt(Mid(fn, InStrRev(fn, "\", , vbTextCompare) + 1, (InStrRev(fn, ".", , vbTextCompare)) - (InStrRev(fn, "\", , vbTextCompare) + 1))))
Range("B" + CStr(i + 1)).Select
ActiveCell.FormulaR1C1 = Trim(Mid(TEMP(4), 23, 18))
Selection.NumberFormat = "dd/mm/yy hh:mm;@"
strF = strF - 1
Range("C" + CStr(i + 1)).Select
ActiveCell.FormulaR1C1 = CStr(Mid(TEMP(strF), InStrRev(TEMP(strF), ",", , vbTextCompare) + 1, InStrRev(TEMP(strF), ".", , vbTextCompare) + 2))
Range("D" + CStr(i + 1)).Select
ActiveCell.Formula = "=" + CStr("B" + CStr(i + 1) + "+C" + CStr(i + 1) + "/3600/24/2")
Range("E" + CStr(i + 1)).Select
ActiveCell.Formula = "=(D" + CStr(i + 1) + "-B$3)*24"
j = 8
Do While Trim(TEMP(j)) <> ""
If (Trim(Mid(TEMP(j), aktpos, pogrpos - aktpos))) <> "" Then
For l = 6 To k - 1
Range(Cells(1, l), Cells(1, l)).Select
If (ActiveCell.Formula = Mid(Trim(TEMP(j)), 1, InStr(1, Trim(TEMP(j)), " ", vbTextCompare) - 1)) Then
Range(Cells(i + 1, l), Cells(i + 1, l)).Select
ActiveCell.Formula = Trim(Mid(Trim(TEMP(j)), aktpos, pogrpos - aktpos))
Exit For
End If

Next l
End If
j = j + 1
Loop

j = 8
Do While Trim(TEMP(j)) <> ""
If (Trim(Mid(Trim(TEMP(j)), aktpos, pogrpos - aktpos))) <> "" Then
nuklvst = False
For l = 6 To k - 1
Range(Cells(1, l), Cells(1, l)).Select
If (ActiveCell.Formula = Mid(Trim(TEMP(j)), 1, InStr(1, Trim(TEMP(j)), " ", vbTextCompare) - 1)) Then
nuklvst = True
Exit For
End If
Next l
If nuklvst = False Then
Range(Cells(1, k), Cells(1, k)).Select
ActiveCell.Formula = Mid(Trim(TEMP(j)), 1, InStr(1, Trim(TEMP(j)), " ", vbTextCompare) - 1)
Range(Cells(i + 1, k), Cells(i + 1, k)).Select
ActiveCell.Formula = Trim(Mid(Trim(TEMP(j)), aktpos, pogrpos - aktpos))
If (Trim(Mid(Trim(TEMP(j)), perpos, aktpos - perpos)) <> "") Then
Range(Cells(2, k), Cells(2, k)).Select
ActiveCell.Formula = Trim(Mid(Trim(TEMP(j)), perpos, aktpos - perpos))
End If
k = k + 1
End If
End If
j = j + 1
Loop

End If
GoTo label1
label2:

Else ' User chose No.
pr = 1
Open fn For Input Access Read Shared As #1 'открытие файла
Do While Not (EOF(1)) 'пока не конец файла (обращение к файлу по номеру)
Line Input #1, TEMP(strF + 1) 'Ввод данных в переменную TEMP без chr(10)&chr(13)
LTrim (RTrim(TEMP(strF + 1)))
strF = strF + 1 'Переменная для подсчета числа строк
Loop 'Окончание цикла для подсчета строк
Close #1 'Закрытие файла
For j = 3 To 65536
If IsEmpty(Range(Cells(j, 2), Cells(j, 2))) Then
i = j
Exit For
End If
Next j
i = i - 1

For j = 6 To 256 Step 1
If IsEmpty(Cells(1, j)) Then
k = j
Exit For
End If
Next j
label3:
If pr = 1 Then GoTo label5
lensl = InStrRev(fn, "\", , vbTextCompare) + 1
lendot = InStr(InStrRev(fn, "\", , vbTextCompare), fn, ".", vbTextCompare)
fnum = CInt(Mid(fn, lensl, lendot - lensl)) + 1
zerolen = lendot - 1 - lensl - Len(CStr(fnum))
'For j = 1 To zerolen
'nfn = nfn + "0"
'Next j
'nfn = nfn + CStr(fnum)
'nfn = nfn + ".RPT"
'nfn = Mid(fn, 1, InStrRev(fn, "\", , vbTextCompare) + 1) + nfn
'fn = nfn

filenum = CInt(Mid(fn, lensl, lendot - lensl)) + 1
lfn = lendot - lensl
'Range(Cells(i + 1, 1), Cells(i + 1, 1)).Select
lcfr = Len(CStr(filenum))
lfn = lendot - lensl - Len(CStr(fnum))
nfn = Mid(fn, 1, InStrRev(fn, "\", , vbTextCompare))
If lfn <> 0 Then
For j = 1 To lfn
nfn = nfn + "0"
Next j
End If
nfn = nfn + CStr(filenum) + ".rpt"
fn = nfn


i = i + 1
FileName$ = fn

If (VerifyFile(FileName$) = False) Then GoTo label4
If (VerifyFile(FileName$)) Then
strF = 0
Open fn For Input Access Read Shared As #1 'открытие файла
Do While Not (EOF(1)) 'пока не конец файла (обращение к файлу по номеру)
Line Input #1, TEMP(strF + 1) 'Ввод данных в переменную TEMP без chr(10)&chr(13)
LTrim (RTrim(TEMP(strF + 1)))
strF = strF + 1 'Переменная для подсчета числа строк
Loop 'Окончание цикла для подсчета строк
Close #1 'Закрытие файла
label5:
pr = 5
nuklpos = InStr(1, Trim(TEMP(6)), "Н", vbTextCompare)
aktpos = InStr(1, Trim(TEMP(6)), "А", vbTextCompare) + 1
pogrpos = InStr(aktpos, Trim(TEMP(6)), "П", vbTextCompare) - (InStr(aktpos, Trim(TEMP(6)), "П", vbTextCompare) - InStr(aktpos, Trim(TEMP(6)), ",", vbTextCompare))

Range("A" + CStr(i + 1)).Select
ActiveCell.FormulaR1C1 = CStr(CInt(Mid(fn, InStrRev(fn, "\", , vbTextCompare) + 1, (InStrRev(fn, ".", , vbTextCompare)) - (InStrRev(fn, "\", , vbTextCompare) + 1))))
Range("B" + CStr(i + 1)).Select
ActiveCell.FormulaR1C1 = Trim(Mid(TEMP(4), 23, 18))
Selection.NumberFormat = "dd/mm/yy hh:mm;@"
strF = strF - 1
Range("C" + CStr(i + 1)).Select
ActiveCell.FormulaR1C1 = CStr(Mid(TEMP(strF), InStrRev(TEMP(strF), ",", , vbTextCompare) + 1, InStrRev(TEMP(strF), ".", , vbTextCompare) + 2))
Range("D" + CStr(i + 1)).Select
ActiveCell.Formula = "=" + CStr("B" + CStr(i + 1) + "+C" + CStr(i + 1) + "/3600/24/2")
Range("E" + CStr(i + 1)).Select
ActiveCell.Formula = "=(D" + CStr(i + 1) + "-B$3)*24"
j = 8
Do While Trim(TEMP(j)) <> ""
If (Trim(Mid(TEMP(j), aktpos, pogrpos - aktpos))) <> "" Then
For l = 6 To k - 1
Range(Cells(1, l), Cells(1, l)).Select
If (ActiveCell.Formula = Mid(Trim(TEMP(j)), 1, InStr(1, Trim(TEMP(j)), " ", vbTextCompare) - 1)) Then
Range(Cells(i + 1, l), Cells(i + 1, l)).Select
ActiveCell.Formula = Trim(Mid(Trim(TEMP(j)), aktpos, pogrpos - aktpos))
perpos = InStr(1, Trim(TEMP(6)), "П", vbTextCompare) - 5
'If (Trim(Mid(Trim(TEMP(j)), perpos, aktpos - perpos)) <> "") Then
'Range(Cells(2, k), Cells(2, k)).Select
'ActiveCell.Formula = Trim(Mid(Trim(TEMP(j)), perpos, aktpos - perpos))
'End If
Exit For
End If

Next l
End If
j = j + 1
Loop

j = 8
Do While Trim(TEMP(j)) <> ""
If (Trim(Mid(Trim(TEMP(j)), aktpos, pogrpos - aktpos))) <> "" Then
nuklvst = False
For l = 6 To k - 1
Range(Cells(1, l), Cells(1, l)).Select
If (ActiveCell.Formula = Mid(Trim(TEMP(j)), 1, InStr(1, Trim(TEMP(j)), " ", vbTextCompare) - 1)) Then
nuklvst = True
Exit For
End If
Next l
If nuklvst = False Then
Range(Cells(1, k), Cells(1, k)).Select
ActiveCell.Formula = Mid(Trim(TEMP(j)), 1, InStr(1, Trim(TEMP(j)), " ", vbTextCompare) - 1)
Range(Cells(i + 1, k), Cells(i + 1, k)).Select
ActiveCell.Formula = Trim(Mid(Trim(TEMP(j)), aktpos, pogrpos - aktpos))
If (Trim(Mid(Trim(TEMP(j)), perpos, aktpos - perpos)) <> "") Then
Range(Cells(2, k), Cells(2, k)).Select
ActiveCell.Formula = Trim(Mid(Trim(TEMP(j)), perpos, aktpos - perpos))
End If
k = k + 1
End If
End If
j = j + 1
Loop

End If
GoTo label3
label4:

End If
End Sub
[/more]
h**p://ifolder.ru/3466560 - pass от архива мой ник наоборот
PS. Извиняюсь за стиль написания макроса.

AndVGri
Спасибо за помощь, но мне нужно использовать VBA поскольку это только малая часть
процесса. И мне это удалось. Поэтому вопрос снят. (ниже привожу код).

Код:

Sub ElCel()
Dim WE As Worksheet, WM As Worksheet
Dim ParaEliminar() As String
Dim i As Integer, FinalRow As Integer, j As Integer, k As Integer, z As Integer
Set WE = Worksheets("Eliminar")
Set WM = Worksheets("LISTAGEM")
WM.Select
FinalRowM = Range("A65536").End(xlUp).Row
WE.Select
FinalRowE = Range("A65536").End(xlUp).Row
ReDim ParaEliminar(1 To FinalRowE)
For i = 1 To FinalRowE
' Копирует в массив
ParaEliminar(i) = Cells(i, "A").Value
MsgBox ParaEliminar(i)
Next i
WM.Select
For z = 2 To FinalRowM
' Сверяет с массивом и если есть идентичеые, меняет на "Eliminar este produto"
For j = 1 To FinalRowE
If Cells(z, 1).Value = ParaEliminar(j) Then
Cells(z, 1).Value = "Eliminar este produto"
End If
Next j
Next z
For k = FinalRowM To 2 Step -1
'Удаляет строки у которых строка "A" содержит "Eliminar este produto"
If Cells(k, 1).Value = "Eliminar este produto" Then
Cells(k, 1).EntireRow.Delete
End If
Next k
End Sub

P.S. Лист"MENU" я заменил на Лист"LISTAGEM"

ferias
Может для поиска существующих значений проще использовать Dictionary? Всё-таки хэш таблица - поиск значений по ключу будет идти быстрее. А для чего записывать "Eliminar este produto" - проще сразу удалять эту строку, а не проходить повторно циклом, строка для удаления уже найдена?

MORB_id
Можно, хотя бы убрав лишние в макросе переходы по Select. Записывать данные можно сразу
Range("A1").Value = xxx
Range("A2").Formula ="=xxx"
а не используюя
Range("A1").Select
Activecell.Value = xxx
...
Проверку на существование файла можно и упростить
Dim fso As Object
Set fso = CreateObject("Scripting.FileSystemObject")
If fso.FileExists(FileName) Then ...

Есть файл экзеля, на нем кнопка. По нажатию кнопки нужно создать новый шаблон екзеля и вставить в поле B3 сегодняшнюю дату.
Файл создается но если что-то печатаю..вставляется в файл с кнопкой, а нужно что бы вставлялось в новый...
+вопрос, дата сегодняшняя берется как date()?

Private Sub KAuto_Click()
Application.Workbooks.Add ("распоряжение автокредит")

End Sub

Luciefer
Где печатаешь? Код бы...

Всем привет!
Помогите пожалуйста решить проблемку:
Хочу создать фаил mat.dbf с мемо полями, которые будут помещены в mat.fpt
Пол дня убил на эту заморочку. Нашел только как создать dbf и dbt, а мне необходимо dbf и fpt. Может кто знает?. Напишите пож-та пример.

это и есть пока весь код
надо что бы создавался шаблон, и в него вставлялась ячейка из другого файла
я в экзеле вообще не шарю

Luciefer
Глубокоуважаемейший, а что вы понимаете под шаблоном? В Office это заготовка книги с готовым оформлением, по существу бланк для заполнения типовыми данными (в простейшем случае) на основании которого создаётся конкретная книга. Если нужно создать новый шаблон, то в новой книге выполняют макет, а затем сохраняют как шаблон, который видно в списке шаблонов в Файл/Новый...

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

есчо вопрос
какой надо сделать формат ячейки, что бы дата отображалась как
"август 2007 г." и т.п.
сделал "августа 2007 г.", сделал "Август 2007 г.

а вот как именн "август 2007 г." не знаю

Добавлено:
AndVGri Шаблон я создал
А вот потом надо создать новы файл на основе этого шаблона...
пока сделал вот так...
хотя мне кажется это не вариант
Workbooks.Add Template:= _
"C:\Documents and Settings\Luciefer.SMP_CHEL\Application Data\Microsoft\Шаблоны\распоряжение автокредит.xlt"
With ActiveWindow
.Top = 10.11
.Left = 10.11
End With


P.S. как я понял тут вопросы только по Excel, не по vba...сорри

Luciefer
Может быть, Вам поможет следующее решение? Попробуйте на вашей кнопке такой код:
Код: Private Sub CommandButton1_Click()
Dim wbNew As Workbook
Set wbNew = Application.Workbooks.Add
wbNew.SaveAs Filename:="распоряжение автокредит"
wbNew.Activate
Set wbNew = Nothing
End Sub

AndVGri
Я вам очень признателен за помощь, и в принципе, меня покаместь удовлетворяет то, что у меня есть, но и в то же самое время интересно узнать что-то новое.

Цитата:

Dictionary

- что это такое, и счем его едят? Если у вас есть время? В любом случаи я вам очень благодарен!

Может быть парю, но с ходу не соображу :-\ Каким образом, используя инструментарий Excel VBA, сохранить диаграмму в виде векторного графического файла?

Troitsky
Hmm...

Я пока пользовал

Sub SaveChartAsGIF ()
Fname = ThisWorkbook.Path & "\" & ActiveChart.Name & ".gif"
ActiveChart.Export FileName:=Fname, FilterName:="GIF"
End Sub

Olive77

Цитата:

ActiveChart.Export

Позволяет сохранять только растровые файлы GIF, JPG, TIF и PNG

вот здесь похоже обсуждается
_http://www.experts-exchange.com/Software/Office_Productivity/Office_Suites/MS_Office/Q_10329384.html
вот только теперь просто так не посмотришь

Добавлено:
_http://www.eggheadcafe.com/forumarchives/Excel/Aug2005/post23859860.asp

ferias
Цитата:

Dictionary

думаю, что подробно и применительно к Вашей задаче Вам ответит AndVGri

а я просто кусочек кода приведу (кстати, я про Scripting.Dictionary именно от AndVGri и узнал!!)
[more=пример кода]

Код:
'В редакторе VBA в меню Tools, пункт Reference
' в диалоге поставте галочку для Microsoft Scripting Runtime.

Sub TestDict()
Dim pAll As New Scripting.Dictionary
Dim w1 As Worksheet
Dim rowLast, iRow As Long
Dim vEntry As String

Set w1 = Workbooks("Книга2.xls").Worksheets("Лист1")
rowLast = Cells(w1.UsedRange.Rows.Count + 1, "A").End(xlUp).Row

' сохраним весь столбец А в Scripting.Dictionary для удобства поиска
For iRow = 1& To rowLast
vEntry = CStr(w1.Cells(iRow, "A").Value)
If Not pAll.Exists(vEntry) Then
pAll.Add vEntry, iRow
End If
Next iRow
' в результате этого кода в Dictionary получаются все уникальные строки из столбца А

...
'вот как их можно все перебрать:
For iRow = 0 To pAll.Count - 1
Cells(iRow + 1, 3).Value = pAll.Keys(iRow)
Cells(iRow + 1, 4).Value = pAll.Items(iRow)
Next iRow

End Sub

SERGE_BLIZNUK, спасибо

еще вопросик...
нужно посчитать сумму диапазона ячеек

'
ActiveWorkbook.ActiveSheet.Cells(i+2, 7).Value = "=SUM(R[-2]C:R[-2]C)" - примерно так, но диапазон неправельный
'

нужно посчитать в диапазоне: G9,G11,G13...G[i-1],G[i], i динамическое, но на данный момент уже известное. Это номер последнего столбца чисел, которые и надо сложить.

пробовал ActiveWorkbook.ActiveSheet.Cells(i+2, 7).Value = "=SUM(R[-i+9] C:R[-2]C)
как задать формулу?

Luciefer если я правильно понял, то
просто соберите формулу из кусочков, переводя i в строку
Dim SFormula As String
SFormula = "=SUM("
for i=9 to 13 step 2
SFormula = SFormula & "G" & Trim( Str(i))
if i=13 Then
SFormula = SFormula & ")" ' закрываем формулу
else
SFormula = SFormula & "," ' ещё будут слагаемые
end if
next i
xxxxxxx.Formula = SFormula

SERGE_BLIZNUK, спасибо! работает

еще вопросик...примерно так же нужно объединить 3 ячейки

координаты у них Ci, Di, Ei; C[i+1], D[i+1], R[i+1]. я так понимаю что через Cells не сделать..а через Range не знаю как

Всем привет!
Помогите пожалуйста решить проблемку:
Хочу создать фаил mat.dbf с мемо полями, которые будут помещены в mat.fpt
Пол дня убил на эту заморочку. Нашел только как создать dbf и dbt, а мне необходимо dbf и fpt. Может кто знает?. Напишите пож-та пример.

Добавлено:

Цитата:

еще вопросик...примерно так же нужно объединить 3 ячейки

координаты у них Ci, Di, Ei; C[i+1], D[i+1], R[i+1]. я так понимаю что через Cells не сделать..а через Range не знаю как

Luciefer Если диапазон нужно загнать в формулу, то попробуй так:
Mysumma = ""
For each c in activesheet.range(cells(1,1),cells(9,9))
if Mysumma = "" then Mysumma = "=" & c
else Mysumma = Mysumma & "+" & c
Next
cells(10,10) = Mysumma


Добавлено:
Извиняюсь за некоторую неточность. Правильно будет так:
For Each c In ActiveSheet.Range(Cells(1, 1), Cells(9, 9))
If Mysumma = "" Then
Mysumma = "=" & c
ElseIf c <> "" Then
Mysumma = Mysumma & "+" & c
End If
Next
Cells(10, 10) = Replace(Mysumma, ",", ".")


Добавлено:
А если динамическое, то так
For Each c In ActiveSheet.Range(Cells(1, 1), Cells(9, 9))
If Mysumma = "" Then
Mysumma = "=" & c.Address
ElseIf c <> "" Then
Mysumma = Mysumma & "+" & c.Address
End If
Next
Cells(10, 10) = Replace(Mysumma, ",", ".")

решил проблему с диапазоном вот так
ActiveWorkbook.ActiveSheet.Range("C" & Trim(Str(i + 1)) & ":" & "E" & Trim(Str(i + 1))).MergeCells = True

Troitsky

Цитата:

Позволяет сохранять только растровые файлы GIF, JPG, TIF и PNG

[more]
Private Declare Function OpenClipboard Lib "User32" _
(ByVal hwnd As Long) As Long

Private Declare Function CloseClipboard Lib "User32" () As Long

Private Declare Function GetClipboardData Lib "User32" _
(ByVal uFormat As Long) As Long

Private Declare Function CopyEnhMetaFileA Lib "Gdi32" _
(ByVal hENHSrc As Long, ByVal lpszFile As String) As Long

Private Declare Function DeleteEnhMetaFile Lib "Gdi32" _
(ByVal hdc As Long) As Long

Sub ExportPictureAsEmf()
Dim myEmfFile, Rep As Long

Do
myEmfFile = Application.GetSaveAsFilename("Test", _
"Windows metafile (*.emf),*.emf", , "Exporting ...")
If VarType(myEmfFile) = vbBoolean Then Exit Sub

If Dir$(myEmfFile) <> "" Then
Rep = MsgBox("The file " & myEmfFile & " already exists. " _
& "Would you like to replace it?", vbYesNoCancel + vbQuestion)
If Rep = vbCancel Then Exit Sub
If Rep = vbYes Then
Kill myEmfFile
Exit Do
End If
Else
Exit Do
End If
Loop

If CopyMyEmfFile(ActiveChart, CStr(myEmfFile), xlScreen, xlPicture) = "" Then
MsgBox "Error!", vbCritical
Else
MsgBox "Chart is saved into " & myEmfFile & " ."
End If

End Sub

Private Function CopyMyEmfFile(myObject As Object, _
sFileNameFull As String, Optional iAppearance, _
Optional iFormat, Optional iSize) As String
Const CF_ENHMETAFILE As Long = 14

If TypeName(myObject) <> "Chart" Then
myObject.CopyPicture iAppearance, iFormat
Else
myObject.CopyPicture iAppearance, iFormat, iSize
End If

OpenClipboard 0
If DeleteEnhMetaFile(CopyEnhMetaFileA(GetClipboardData(CF_ENHMETAFILE), sFileNameFull)) = 0 Then
CopyMyEmfFile = ""
Else
CopyMyEmfFile = sFileNameFull
End If

CloseClipboard
End Function

[/more]

как наприсать макрос запускающий несколько макросов при открытии файла последовательно?
есть команда при открытии или как?

Olive77
Ну, я так и думал. Встроенных средств для этих целей, видимо, нет и без использования буфера обмана не обойтись :-\
Работая из VB, можно было бы особо не мудрить, а использовать подобный код:
Код: ' ActiveChart.ChartArea.Copy
SavePicture Clipboard.GetData(vbCFMetaFile), "c:\test.wmf"
SavePicture Clipboard.GetData(vbCFEMetaFile), "c:\test.emf"

AndVGri
Скорость увеличилась в разы. Код с файлом я оставил таким же, потому как с скриптами не оч хочеца.

Подскажите, пожалуйста, можно ли в ListBox выделить значение, которое находится в выделенной нами ячейке на листе (в заданном для ListBox диапазоне)?