» Excel VBA (часть 2)

real_knacker
так?
Код:
Dim Filename As String
Filename = Application.GetOpenFilename("My Price (*.xls), *.xls", , _
"Открытие нужного файла")
MsgBox "==" & Filename

130635
На основе функций ПОИСК() или НАЙТИ() (application.WorksheetFunction.Find)
Если "WWW" находит, то начинаем выстригать адрес из общей текстовой строки: начало "www" конец либо " " либо com, ru

как сделать поиск подстроки, содержащейся в ячейке An(1<n<10000) в столбце A1:A200000 на другом листе?

Добрый вечер!!! Не могли бы разобраться в задаче...Учитель дал типа разберись и подходи...ПЛЗ

Sub FirstProgram()

'Блок описания переменных
Dim i As Integer, D(1 To 3) As Single, Dt(1 To 3) As Single, C(1 To 3) As Single, Delta As Single, Delta0 As Single, _
k As Single, dk As Single, S As Single

'Блок установки начальных значений
C(1) = 1.02
C(2) = 1.52
C(3) = 2.52
D(1) = 0.105
D(2) = 0.215
D(3) = 0.275
k = 1
dk = 0.01

'Программа
Dt(1) = k * C(1)
Dt(2) = k * C(2)
Dt(3) = k * C(3)


S = 0
For i = 1 To 3
S = S + (Dt(i) - D(i)) ^ 2
Next
Delta0 = S
MsgBox "Delta0 = " & S


k = k + dk
Dt(1) = k * C(1)
Dt(2) = k * C(2)
Dt(3) = k * C(3)

S = 0
For i = 1 To 3
S = S + (Dt(i) - D(i)) ^ 2
Next
Delta = S
MsgBox "Delta = " & S

If Delta > Delta0 Then
dk = -dk
k = k + 2 * dk
Dt(1) = k * C(1)
Dt(2) = k * C(2)
Dt(3) = k * C(3)

S = 0
For i = 1 To 3
S = S + (Dt(i) - D(i)) ^ 2
Next
Delta = S
End If


While Delta < Delta0
Delta0 = Delta
k = k + dk
Dt(1) = k * C(1)
Dt(2) = k * C(2)
Dt(3) = k * C(3)

S = 0
For i = 1 To 3
S = S + (Dt(i) - D(i)) ^ 2
Next
Delta = S
Wend

k = k - dk

MsgBox k

Range("A1").Value = k

End Sub

Подскажите, можно ли осуществить такое.... точнее как это можно сделать средствами excel:
Есть таблица вида

ФИО1
04 001 12000
04 002 13000
04 003 14000
ФИО2
04 001 11000
04 008 13000
04 045 10000
04 087 290
...

Можно ли сформировать таблицу:
ФИО1
12000 13000 14000
ФИО2
11000 13000 10000 290
...

Т.е. взять значения 3-го столбика для каждой фамилии и записать их в строку.

exileX, можно через не очень сложный макрос..

Люди, а кто может помочь с такой проблемой - есть два файла эксель, нужно сделать такую штуку - если одна ячейка совпадает с другой ячейкой, то копировать значение из третьей ячейки в четвертую ячейку)))

наверно непонятно конечно, но вот конкретно: есть опись с номерами, есть опись с такими же номерами, но другой структуры. в одной описи указано что под таким то номером находится такое то оборудование, во второй - указано только лицо ответственное за этот номер, и сделать нужно так, что если номера совпадают, то перенести наименование оборудования в ячейку рядом с отв. лицо...

xokkeist77, это легко делается без всяких макросов!
используйте функцию =ВПР(...)

Прошу помочь вот в каком вопросе. Есть у меня файл с макросом. И файл работал и в Excel 2000 и Excel 2003. Но тут нам усилили безопасность. И в итоге под моей учеткой все работает, под пользовательскими учетками не работает. Выходит сообщение "Can't find project or library". Есть ссылка http://forum.shelek.ru/index.php/topic,821.0.html
Под пользовательским учетками меню Tools -> References не доступно. Под моей учеткой там есть missing запись, но у меня же все работает. Кто может что-то предложить?

Добавлено:
Прочим, что странно. Я эту библиотечку руками подгружаю, а она все равно missing

размерность Excel-VBA Chart.XValues (типа массив)?


Есть книга Excel, в ней страница для диаграммы.
Программный код VBA создает диаграмму из точек, и строит графики-отрезки, задавая программно массив (array) значений (с Range не получится, ибо она рваная, а собирать воедино довольно долго).
Диаграмму делает следующий код (упрощен):

Sub tembsub()
Dim arXs() As Integer
Dim arYs() As Single
Set wsd = Application.ThisWorkbook.Worksheets(1)
' ochischaem oblast' diagrammy
wsd.ChartObjects.Delete
wsd.Select
wsd.Range("A1:IV32000").Select
Selection.Delete Shift:=xlToLeft

For i = 0 To 100
ReDim Preserve arXs(i)
ReDim Preserve arYs(i)
arXs(i) = i
arYs(i) = i + i + 3
Next i

' sozdaem diagrammu
wsd.ChartObjects.Add 100, 30, 400, 250
Set oc = wsd.ChartObjects(1).Chart
oc.ChartType = xlXYScatterSmoothNoMarkers
oc.SeriesCollection.NewSeries
oc.SeriesCollection(1).XValues = arXs
oc.SeriesCollection(1).Values = arYs
oc.SeriesCollection(1).Name = "=""Chast' """
End Sub

Когда размерность массива arXs() находится где-то в пределах пары десятков - все нормально, диаграмма рисуется.
Когда эта размерность приближается к 100 (а у меня хорошо за 600!) - выдается ошибка:

Run-time error '1004': Нельзя установить свойство XValues класса Series

Какая же эта размерность на самом деле (есть ли информация) и как это обойти - чтобы загнать в качестве источника данных массив на пол-тысячи позиций?

Макрос в Excel заканчивает свою работу копированием нескольких строк из Excel в Word. Excel закрывается без сохранения.

Worksheets(1).Range(x, y).Select
With Selection.Font
.Name = "Times New Roman"
.Size = 12
End With
Selection.Copy

With CreateObject("Word.Application")
.Documents.Add
.Selection.Paste
.Visible = True
.Activate
End With

ActiveWorkbook.Close False
Excel.Application.Quit

PasteSpecial не срабатывает. Выдает ошибку.
Собственно проблема не могу заставить макрос вставлять неформатированный текст в Word. Что не было таблицы. Вручную делал раньше через спецвставку. Я так понял команды спецвставки из Excel не подходят Word.

Помогите новичку! Записал макрос, который создает книгу и сохраняет её на диск С:\ под именем "Анализ стоимости материалов.xls" в которую копируется лист "Отчет", подскажите как сделать чтобы при сохранении файла к имени "Анализ стоимости материалов" добавлялись текущая дата и время или текст из определенной ячейки

Sub Сформировать_отчет()
Workbooks.Add
ActiveWorkbook.SaveAs Filename:="C:\Анализ стоимости материалов.xls", _
FileFormat:=xlNormal, Password:="", WriteResPassword:="", _
ReadOnlyRecommended:=False, CreateBackup:=False
Windows("Материалы-2.xls").Activate
Sheets("Отчет").Select
Sheets("Отчет").Copy Before:=Workbooks("Анализ стоимости материалов.xls"). _
Sheets(1)
ActiveSheet.Shapes("Button 1").Select
Selection.Delete
Cells.Select
Selection.Copy
Cells.Select
Application.CutCopyMode = False
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Range("E8").Select
Application.CutCopyMode = False
ActiveCell.FormulaR1C1 = ""
Range("E2").Select
ActiveWorkbook.Save
End Sub

Очень жду помощи, заранее благодарен!

MuLLIka
Попробуйте так:

Код: Sub Сформировать_отчет()
Application.ScreenUpdating = False: Sheets("Отчет").Copy: ActiveSheet.Shapes(1).Delete
ActiveSheet.SaveAs Filename:="C:\Анализ стоимости материалов " & Format(Now, "dd.mm.yyyy hh.mm.ss") & ".xls"
ActiveWorkbook.Close SaveChanges:=False
End Sub

Здравствуйте.
Написал код для кнопок, чтобы циклически сдвигать содержимое (вправо, влево) в одномерном горизонтальном дипазоне из 12 ячеек:


Код: Sub RightScroll()
Dim a1 As String
Dim buf As String
ActiveCell.Offset(0, 11).Select
a1 = ActiveCell.Address
buf = Range(a1)
For y = 1 To 11
ActiveCell.Offset(0, -1).Select
Range(a1).Value = Range(ActiveCell.Address)
a1 = ActiveCell.Address
Next y
Range(a1).Value = buf
End Sub

Sub LeftScroll()
Dim a1 As String
Dim buf As String
a1 = ActiveCell.Address
buf = Range(a1)
For y = 1 To 11
ActiveCell.Offset(0, 1).Select
Range(a1).Value = Range(ActiveCell.Address)
a1 = ActiveCell.Address
Next y
Range(a1).Value = buf
ActiveCell.Offset(0, -11).Select
End Sub

VictorKos
Для сдвига влево, выделите любую ячейку в требуемой строке и выполните макрос:

Код: Sub LeftScroll()
Dim i As Integer, buf, a()
a = Range(Cells(ActiveCell.Row, "F"), Cells(ActiveCell.Row, "Q")).Value: buf = a(1, 1)
For i = 1 To UBound(a, 2) - 1: a(1, i) = a(1, i + 1): Next
a(1, UBound(a, 2)) = buf: Range(Cells(ActiveCell.Row, "F"), Cells(ActiveCell.Row, "Q")).Value = a
End Sub

SAS888
Спасибо, буду разбираться.

Всем привет.

Может кто-нибудь сможет решить такое задание: Дан список из какого-то числа фамилий на листе (в столбик). Все эти фамилии надо загнать в массив и отсортировать, чтобы не было повторений и записи были в алфавитном порядке. Массив нужен для того, чтобы разместить его в дальнейшем в ListBox_е для выбора фамилий.

Сам застопорился на удалении повторов фамилий в массиве

У меня вопрос.
Ну никак не пойму как это сделать...
Наверняка все просто, но мне знаний моих недостаточно.

Дело в следующем.
Надо считать около сотни значений из столбца таблицы Excel и присвоить их такому же количеству переменных,
после чего делаются вычисления и результаты записываются обратно в таблицу Excel.

Я понял, что последнее можно сделать следующим образом:
Sheets("Лист1").Range("B1:B100").Value=Array(Значение1, Значение2, ..., Значение100)

А как сделать в обратном порядке?
Чтобы можно было Значение1, Значение2, ..., Значение100 столбца назначить соответственно Переменной1, Переменной2, ..., Переменной100.

При попытке поменять местами и сделать Array(...)=Range(...) вылетает ошибка...

Если бы было только парочка значений, тогда бы сделал просто Переменная=Range().Value и т.д.
Но там более сотни!

protazzz
Сортировать не надо. ListBox сам отсортирует. Свойство Sort = true
По алгоритму:
1.вычитываем первую фамилию и в массив
2.вычитываем следующую
3.пробегаемся по массиву и сравниваем.
если нашли такую же, то остановились; перешли на пункт 2
если нет, добавили в маcсив; перешли на пункт 2

Можно и без массива, прямо добавлять в ListBox. Но с массивом будет несколько быстрее.

dneprcomp, Спасибо, вот что получилось :::



Цитата:

Sub SelectionFind()
Dim mass(1 To 100) As String
Dim mass2(1 To 100) As String

For i = 1 To 100
If Worksheets("Лист3").Cells(i, 1) <> "" Then
mass(i - 1) = Worksheets("Лист3").Cells(i, 1)
y = y + 1
End If
Next i

For i = 1 To y
Worksheets("Лист3").Cells(i + 1, 2) = mass(i)
Next i

i = 1
j = 1
k = 1
n = y

For j = 1 To y
If mass(j) <> "" Then
mass2(k) = mass(j)
For i = 1 To n
If mass2(k) = mass(i) Then
mass(i) = ""
End If
Next i
k = k + 1
End If
Next j

End Sub

Единственный вопрос, который остался - как связать массив и ComboBox, чтобы не было пустых строк внизу? ReDim почему-то выдает ошибку

protazzz
Для redim обявление массива должно быть без явного числа элементов
Dim mass3() As String
Затем использовать
redim mass3(5)
или
redim preserve mass3(5)

Цитата:

как связать массив и ComboBox, чтобы не было пустых строк внизу

Массив не связывают. В ComboBox добавляют в цикле командой ComboBox.AddItem
Откуда вообще берутся пустые строки? Или не вноси в массив изначально, или не добавляй в ComboBox
PS. У массивов есть такое удобное свойство как Ubound
For i = 1 To Ubound(mass) 'y
Worksheets("Лист3").Cells(i + 1, 2) = mass(i)
Next i

dneprcomp Спасибо, помогло внесение команды "AddItem". Пустые же "ячейки" образовывались на этапе назначения размера массива. В моём случае он был 1 - 100, т.е. очень большая размерность при малой заполненности.

jurris
Sub test()
Dim i As Long, k As Long
Dim list() As Variant
k = Range("A65536").End(xlUp).Row'вычесляем, снизу в верх, первую задействованную ячейку в столбце A
ReDim list(1 To k)'устанвливаем размер массива от 1 до k, в сдучаи если верхняя граница диапазона ячейка A1,а нижняя граница столбец A и где номером строки является, переменная k
For i = 1 To k'с помощью цикла, вноси значения в массив list()
list(i) = Cells(i, 1).Value
Next i
For i = 1 To k'с помощью цикла, присваиваим значения ячейкам в столбце B
Cells(i, 2).Value = list(i)
Next i
End Sub

ferias
Спасибо!

protazzz

Цитата:

очень большая размерность при малой заполненности.

При достижении первого же пустого значения массива в твоем случае можно уже останавливать перебор и добавления командой Exit For

protazzz
dneprcomp
Сформировать одномерный массив из уникальных значений диапазона "A1:A100", не содержащий пустые значения, можно существенно проще (один цикл):

Код: Sub SelectionFind()
Dim i As Long, x As New Collection, mass() As String, a()
a = Sheets("Лист3").[A1:A100].Value: ReDim mass(1 To 1)
For i = 1 To UBound(a, 1)
If a(i, 1) <> "" Then
On Error Resume Next: x.Add a(i, 1), CStr(a(i, 1))
If Err = 0 Then
mass(UBound(mass)) = a(i, 1): ReDim Preserve mass(1 To UBound(mass) + 1)
Else: On Error GoTo 0
End If
End If
Next
ReDim Preserve mass(1 To UBound(mass) - 1)
End Sub

возможно ли написать макрос который добавляет к имени фалов значение ячейки(например А1)
при условии
1 файлы находятся в одной папке
2 файлов много, имена файлов разные, файлы все закрытые
3 содержание А1 в каждом файле разное
4 в конец имени каждого файла должно быть дописано содеражание ячейки(А1)

SAS888
Конечно можно. Я ведь с кодом protazzz и не разбирался. Так, несколько решений на уровне алгоритмов подсказал. Подсказать одно, писать за кого-то код - другое

PS. При больших массивах ReDim Preserve займет много времени. Нерационально переписывать массив на каждом значении.


Добавлено:
DenisSmo
Все можно.
http://www.fmsinc.com/FRee/NewTips/Access/accesstip31.asp
http://www.blueclaw-db.com/listbox-directory.htm

dneprcomp

Цитата:

При больших массивах ReDim Preserve займет много времени. Нерационально переписывать массив на каждом значении

Это все равно будет гораздо быстрее, чем использовать несколько циклов работы с ячейками листа Excel.

Добавлено:
DenisSmo
Решение Вашей задачи достаточно простое, если имя листа, содержащего в ячейке "A1" значение для добавления к имени файла во всех файлах одинаковое и известное (в примере это "Литст1"). Только в этом случае можно получить значение ячейки не открывая файл (либо при помощи ссылки, либо макросом XLM). Если устраивает, то следующий код переименует все файлы с расширением ".xls" согласно Вашему требованию.

Код: Sub Main()
Dim FPath As String, FName As String, x As String
FPath = ThisWorkbook.path & Application.PathSeparator: FName = Dir(FPath & "*.xls")
Do While FName <> ""
If FName <> ThisWorkbook.Name Then
x = ExecuteExcel4Macro("'" & FPath & "[" & FName & "]Лист1'!" & Range([A1].Address).Range("A1").Address(, , xlR1C1))
Name FPath & FName As FPath & Left(FName, Len(FName) - 4) & x & ".xls"
End If
FName = Dir
Loop
End Sub

Как скопировать группу ячеек, например A1:D10 из макроса Excel, в созданный этим макросом документ Word, с помощью selection.copy, чтобы не было таблицы.
То есть неформатированный текст.