» Excel VBA (часть 3)

Всем привет, ещё раз спасибо за прошлую подсказку, у меня тут ещё пара вопросов возникло:
1) есть табличка под которой стоят чекбоксы, табличка постоянно добавляется новыми строчками, чекбоксы, созданные руками отлично перемещаются вместе с добавлением, НО время от времени туда надо добавлять новые столбцы, под которыми тоже нужны чекбоксы, вручную добавить без проблем, но табличкой будут пользоваться "несведущие" люди, хочу поставить макрос который проверит все непустые столбы(по определённой строчке) и проверит стоит ли под ней чекбокс, если нет то поставит. Сложность именно в том что таблица динамически обновляется, и непонятно как определить координаты для чекбокса.
2)хочу подключить dll но там реализована возможность только записи информации в ячейки... вопрос в том, есть ли способ запуска макроса не непосредственным вызовом, а фактом изменения содержания ячейки?
3)в таблице есть столбец с датами прописанными в виде dd.mm.yy форматированием изменил отображение на вид: "понедельник,13,август" .А теперь хочу отфильтровать по дню недели, и никак не получается. Перепробовал куча вариантов, никак не реагирует...

anomalia13

Цитата:

1) и непонятно как определить координаты для чекбокса.

узнать координату у уже существующих чекбоксов
или строку в которой чекбоксы назвать и узнавать координату именованной области Sheet.Range("checkbox_row_name")


Цитата:

2)есть ли способ запуска макроса не непосредственным вызовом, а фактом изменения содержания ячейки?

в Visual Basic выбрать ЭтаКнига макрос для Workbook событие SheetChange будет срабатывать для всех листов

Код:
Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
End Sub

Доброго времени суток всем!
есть открытая книга, нужно в ячейку "М+" вставить значение из таблицы другой книги
Формула в ячейке "М5" ВПР(C5;'N:\Print_2\[K2.xls]N2_N1'!$E$6:$AA$3550;5;0), работает нормально (книга N:\Print_2\[K2.xls]; лист N2_N1)
Нужно написать макрос для колонки М, ячеек 5-2000.
попытка написать типа такого:
For i = 5 To 2000
Range("M" + CStr(i)) = VLOOKUP(("C" + CStr(i)),'N:\Print_2\[K2.xls]N2_N1'!$E$6:$AA$3550,5,0)
next
выдает ошибку еще при написании макроса, красным цветом строка с формулой
Помогите, ПЛИЗЗЗЗ

ага, спасибо, но тут тоже не всё понятно,
начну с конца, weekDay я пробовал, ставлю такой фильтр, msgbox по этим координатам показывает "5", а при фмльтровке он скрывает ВСЕ строки, даже указанную в координатах не оставляет...

ActiveSheet.Range("$A$3:$BO$338").AutoFilter Field:=2, Criteria1:=Weekday(Cells(Last_Rows_, 2).Value, vbMonday)

со вторым вроде разобрался

по поводу третьего... а можно пример кода как чекбокс установить по адресу ячейки?!

kramrus
с циклом

Код: [no]For i = 5 To 2000
Range("M" + CStr(i)) = "=VLOOKUP(C" + CStr(i) + ",'N:\Print_2\[K2.xls]N2_N1'!$E$6:$AA$3550,5,0)"
Next
[/no]

smirnvlad
Спасибо большое! все заработало.
Поскольку нужно выборка из 3 столбцов, проверил все на Цикле, прописав дополнительно 2 ячейки "N" и "O"
эти 2 кода вставляют формулу в нужную ячейку, и идет расчет формулы.
Это вариант, но я люблю докапываться до мелочей и познавать все насколько можно.
Соответственно вопрос: а не подскажите как это прописать не вставкой формулы в ячейку, а полноценным макросом. Сколько ни лазил на форумах, так и не понял как работает эта функция в макросах. Хотелось бы понять а не тупо скопировать готовое решение

kramrus
В макросе
Range("M" + CStr(i)).Value = Application.VLookup(Range("C" + CStr(i)).Value, Application.Workbooks("K2.xls").Sheets("N2_N1").Range("$E$6:$AA$3550"), 5, 0)
но для этого нужно предварительно открыть книгу Application.Workbooks.Open("N:\Print_2\K2.xls")

если нужны значения, а не формулы то быстрее будет сделать специальную вставку значений, чем в макросе считать 2000 строк
Range("M5:M2000") = "=VLOOKUP(RC[-10],'N:\Print_2\[K2.xls]N2_N1'!R6C5:R3550C27,5,0)"
Range("M5:M2000").Copy
Range("M5:M2000").PasteSpecial Paste:=xlPasteValues
Application.CutCopyMode = False

Цитата:

smirnvlad

всё, разобрался, спасибо,
вот бы ещё кто подсказал как по дням недели фильтровать ....

anomalia13

Цитата:

как по дням недели фильтровать

используя дополнительный столбец
[more=пример для пустого листа]
Код: [no]
Range("C2").Select
ActiveCell.FormulaR1C1 = "Дата"
Range("C3").Select
ActiveCell.FormulaR1C1 = "1/1/2010"
Range("C4").Select
Columns("C:C").ColumnWidth = 17.43
Range("D3").Select
ActiveCell.FormulaR1C1 = "=RC[-1]"
Range("D3").Select
Selection.NumberFormat = "dddd"
Range("C3:D3").Select
Selection.AutoFill Destination:=Range("C3:D23"), Type:=xlFillDefault
Range("C2:D23").Select
Range("D23").Activate
Selection.AutoFilter
ActiveSheet.Range("C2").AutoFilter Field:=1, Visibledropdown:=False
Range("D2").Select
Columns("D:D").ColumnWidth = 12.14
[/no]

smirnvlad
спасибо за объяснение в примере. книгу придется открывать в любом случае....
с открытой книгой работает быстрее, и макрос наверно лучше прописать один раз в "К_2", а не в каждой новой книге.
И если "Мёд да еще и ложкой", вопрос: можно ли каким то образом сохранить полученные значения в ячейках "М5:М2000" сохранить в *.тхт документе столбцом. Хотя скопировать столбец и вставить в тхт документ не так уж и сложно.
Еще раз спасибо за подсказки и полученные мной знания.

kramrus

Цитата:

сохранить в *.тхт документе столбцом

[more]
Код: [no]
Sub savetotxt()
data = Range("D5:D20").Value
fname = ThisWorkbook.FullName & ".txt"

fnum = FreeFile()
Open fname For Output As fnum
On Error GoTo CloseFile:

For s = LBound(data) To UBound(data)
Print #fnum, data(s, 1)
Next

Close fnum

Shell PathNAme:="notepad """ & fname & """", WindowStyle:=vbNormalFocus
Exit Sub

CloseFile:
Close fnum

End Sub
[/no]

Спасибо БОЛЬШОЕ

smirnvlad
kramrus
Сохранить значения из диапазона "D5:D20" в текстовый файл, расположив их в столбец, можно существенно проще:

Код: Sub SaveToText()
Set fso = CreateObject("Scripting.FileSystemObject")
Set ts = fso.OpenTextFile(fso.GetBaseName(ThisWorkbook.Name) & ".txt", 2, True)
ts.Write Join(Application.Transpose(Application.Index([D5:D20].Value, 0, 1)), Chr(10))
ts.Close
End Sub

Снова здравствуйте, господа эксперты.

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

Есть таблица, в столбце A тикеры (кодовые обозначения) ценных бумаг, обращающихся на ММВБ. Нужен макрос, позволяющий автоматически добавлять в указанные ячейки (например, столбец B) актуальные котировки данных ценных бумаг.

Заранее спасибо.

Веб запрос на временный лист(сделаете через записать макрос), затем впр на исходный лист.
Айс? или нужно более подробно?

Drazhar
не очень айс( Нужны не все котировки, а лишь те, которые входят в инвестиционный портфель, который через ВПР копируется с другого листа... Структура портфеля периодически меняется ==> меняются и сами тикеры

Ну а в чем проблема?
добавляете временный лист, на который подтягиваются все котировки, а вы уже ВПРом накидываете те тикеры которые надо.

ошибся, убежал сюда

Drazhar
проблема в том, что ММВБ не предоставляет бесплатный доступ к xml-файлу со всеми актуальными котировками, а найти сторонний ресурс, который делает такую таблицу, пока не получается.

mikhael02
Поднять Quik и настроить экспорт по DDE без шансов?

mikhael02
можно через IE, но ...

[more]
создаст файлы 1. %.txt.html в корне диска C

Код: [no]
Set ie1 = CreateObject("InternetExplorer.Application")
ie1.Visible = True
ie1.Navigate2 "http://www.micex.ru/marketdata/quotes"
While ie1.ReadyState < READYSTATE_COMPLETE
Application.Wait (Now + TimeValue("00:00:01"))
Wend
While ie1.Busy = True
Application.Wait (Now + TimeValue("00:00:01"))
Wend
While Len(ie1.Document.getElementById("instrument-table").InnerHTML) < 500
Application.Wait (Now + TimeValue("00:00:01"))
Wend



i = 1
f = FreeFile
Open "c:\1." + Str$(i) + ".txt.html" For Output As #f
Print #f, ie1.Document.getElementById("instrument-table").OuterHTML
Close #f

While Not ie1.Document.getElementById("instrument-pager-next").className = "disabled"

ie1.Document.getElementById("instrument-pager-next").Click

While ie1.ReadyState < READYSTATE_COMPLETE
Application.Wait (Now + TimeValue("00:00:01"))
Wend
While ie1.Busy = True
Application.Wait (Now + TimeValue("00:00:01"))
Wend
While Len(ie1.Document.getElementById("instrument-table").InnerHTML) < 500
Application.Wait (Now + TimeValue("00:00:01"))
Wend

i = i + 1
f = FreeFile
Open "c:\1." + Str$(i) + ".txt.html" For Output As #f
Print #f, ie1.Document.getElementById("instrument-table").OuterHTML
Close #f

Wend

ie1.Quit

For j = 1 To i
With ActiveSheet.QueryTables.Add(Connection:= _
"FINDER;file:///C:/1." + Str$(j) + ".txt.html", Destination:=Cells(11 * (j - 1) + 1, 1))
.Name = "1." + Str$(i) + ".txt"
.FieldNames = True
.RowNumbers = False
.FillAdjacentFormulas = False
.PreserveFormatting = True
.RefreshOnFileOpen = False
.BackgroundQuery = True
.RefreshStyle = xlInsertDeleteCells
.SavePassword = False
.SaveData = True
.AdjustColumnWidth = True
.RefreshPeriod = 0
.WebSelectionType = xlEntirePage
.WebFormatting = xlWebFormattingNone
.WebPreFormattedTextToColumns = True
.WebConsecutiveDelimitersAsOne = True
.WebSingleBlockTextImport = False
.WebDisableDateRecognition = False
.WebDisableRedirections = False
.Refresh BackgroundQuery:=False
End With
Next

[/no]

задержка в 15 минут((

Drazhar

Цитата:

задержка в 15 минут((

это мне? и к чему относится?

smirnvlad
Человеку вроде как необходимы актуальные данные, а данные на этой странице - с задержкой в 15 минут.

Доброго времени суток!

Как можно скопировать строки, отсортированные автофильтром?
Например, макрос через автофильтр сортирует столбец, и все строки, которые вышли в результате этой сортировки, - копирует.

Заранее спасибо!

З.Ы. Я пробовал записать макрос, но excel привязывается к номерам строк, которые были отсортированы (((

DANYA198
можно так
ActiveSheet.AutoFilter.Range.Copy Destination:=Range("A40")
а можно явно указав область автофильтра
Range("D6:H37").Copy Destination:=Range("A40")
в обоих случаях копируется текущее состояние

Подскажите, пожалуйста.
Нужно удалять строки содержащие определённый номер. Причём количество номеров доходит до 1000.
Например. Нужно удалить строки содержащие 1234567890129012, 1245365221453652... И это должно быть удалено из реестра приблизительно такого вида.
Иванов Иван Иванович 1234567890129012
Сидоров Василий Петрович 1245365221453652
... и т.д.
Вот что нашел на просторах инета. Но это не очень помогает т.к. там помещается только до 50 номеров и приходиться делать новый макрос для следующих 50 номеров. И обязательно нужно, чтобы каждый номер был в кавычках "", а каждый номер вручную в кавычки делать то "крыша едет".

Sub KillRow()
Dim Myrange As Range, C As Range, DelRange As Range
Dim FindRange(), Elem As Variant
Dim FirstAddress As String

Set Myrange = Intersect(ActiveSheet.UsedRange, Columns("C"))
If Myrange Is Nothing Then Exit Sub
Application.ScreenUpdating = False
FindRange = Array("1234567890129012", "1245365221453652") - здесь указываю номера
For Each Elem In FindRange
Set C = Myrange.Find(Elem, Myrange.Cells(1), xlValues, xlPart)
If Not C Is Nothing Then
If DelRange Is Nothing Then Set DelRange = Rows(C.Row)
FirstAddress = C.Address
Do
Set C = Myrange.FindNext(C)
Set DelRange = Union(DelRange, Rows(C.Row))
Loop While FirstAddress <> C.Address
End If
Next
Application.ScreenUpdating = True
If DelRange Is Nothing Then Exit Sub
DelRange.Delete shift:=xlUp
End Sub

Помогите, пожалуйста.

Kiljes
Где-то так
[more]
Процедура работает с активной книгой в которой находятся: лист с таблицей, содержащей строки для удаления, и лист с номерами для удаления

Код:
Public Sub KillNeedRow()
On Error GoTo errHandle
Dim shSource As Worksheet, shNeed As Worksheet
Dim rSource As Range, rNeed As Range
Dim curNeed As Range, delRange As Range, pFind As Range
Dim firstAddress As String

Application.ScreenUpdating = False
'лист, содержащий таблицу со строками для удаления
Set shSource = ActiveWorkbook.Worksheets("Лист1")
'лист, содержащий номера для удаления
Set shNeed = ActiveWorkbook.Worksheets("Лист2")

Set rSource = Application.Intersect(shSource.UsedRange, shSource.Columns("C"))
Set rNeed = shNeed.UsedRange

If rSource Is Nothing Then Exit Sub
If rNeed Is Nothing Then Exit Sub
For Each curNeed In rNeed
Set pFind = rSource.Find(curNeed.Value, rSource.Cells(1), xlValues, XlLookAt.xlWhole)
If Not pFind Is Nothing Then
If delRange Is Nothing Then Set delRange = shSource.Rows(pFind.Row)
firstAddress = pFind.Address
Do
Set pFind = rSource.FindNext(pFind)
Set delRange = Application.Union(delRange, shSource.Rows(pFind.Row))
Loop Until firstAddress = pFind.Address
End If
Next curNeed
If Not delRange Is Nothing Then delRange.Delete XlDeleteShiftDirection.xlShiftUp
Application.ScreenUpdating = True
Exit Sub
errHandle:
Application.ScreenUpdating = True
MsgBox Err.Description, vbOKOnly + vbExclamation, Err.Source
End Sub

Drazhar,
15-минутная задержка - это как раз не самое страшное, без неё лучше, но и с ней как-нибудь проживём.


Цитата:

Поднять Quik и настроить экспорт по DDE без шансов?

прошу пояснить - чайник я

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

mikhael02
Ссылка