Ru-Board.club
← Вернуться в раздел «Прикладное программирование»

» Excel VBA (часть 3)

Автор: aidomars
Дата сообщения: 29.01.2014 16:36

Цитата:
иначе бы не писал репорт

Твоих репортов уже 2 страницы читаем, откуда знать "название и имя текстбокса на свои" мы должны. Долго файл выложить?
Автор: Romka_and_Tany
Дата сообщения: 05.02.2014 11:37
Есть ряд чисел значением от ноля до N фиксированной длины в строке.
Необходимо в другой строке сопоставить каждому значению исходного одномерного массива (строка под строкой) значение-оценку по нарастающей. Т.е. 0 - это 0, найти следующее наименьшее - это 1, следующее (больше предыдущего и меньше других) - 2. Если совпадают значения - оценка одинакова. При изменении исходных данных - переоценка вручную.
Таблица большая - вручную расставлять уже в глазах рябит.
Наверняка решение уже есть. Просто даже не знаю как правильно в поисковом запросе сформулировать вопрос.
Заранее спасибо.
Автор: Alex_Piggy
Дата сообщения: 05.02.2014 16:24
Доброе время, Romka_and_Tany
Вы можете дать конкретный пример? (две исходные строки и результат.)
[more=То, как понял]
Использование - сохранить как модуль. В формуле указываете, например,
=test_me(A1;A2)
- для сравнения содержимого А1 и А2. Просто сравнивает числа. Разделитель - пробел.
Исходные A1 = "1 2 3 4 5", A2 = "1 0 3 2 5" , Результат "= > = < ="

Код:
Function test_Me(Data1 As Range, Data2 As Range)
arr1 = Split(Data1.Value, " ")
arr2 = Split(Data2.Value, " ")
tmpstr = ""
If UBound(arr1) > UBound(arr2) Then
arrsize = UBound(arr2)
Else
arrsize = UBound(arr1)
End If
For i = 0 To arrsize
If arr1(i) = arr2(i) Then
tmpdat = "= "
ElseIf arr1(i) > arr2(i) Then
tmpdat = "> "
Else
tmpdat = "< "
End If
tmpstr = tmpstr & tmpdat
Next
test_Me = Trim(tmpstr)
End Function
Автор: Romka_and_Tany
Дата сообщения: 06.02.2014 09:11
Alex_Piggy, кусок таблицы. В зелёном - оценки расставлены вручную.
Ссылка
Автор: mrdime
Дата сообщения: 06.02.2014 13:00
Народ помогите разобраться с навигацией в макросах Excel.
Мелкомягкие намутили так, что можно голову сломать...
Excel 2010
Есть шаблон Personal.xlsb в котором хранятся все мои макросы.
Т.е. VBAProject в котором есть модули (modules), а в этих модулях могут быть программы (в каком-то модуле одна программа, в каком-то несколько).
На панель быстрого досупа в Excel для удобства выведены кнопки для определенных программ (макросов).
НО проблема в том, что в подсказке к кнопке указан не ПОЛНЫЙ путь к макросу (программе), а только путь к корню. Например:
Personal.xlsb!CopySheet
Самого макроса (программы) CopySheet в VBAProject НЕТ и нету даже модуля с таким названием. CopySheet может находится в модуле RogaIKopyta_blablabla. Когда в VBAProject два десятка модулей в каждом из которых по 3-4 макроса (программы), то найти нужный становится реальной проблемой.
Как побороть это глупое поведение Excel???
Т.е. сделать так, чтобы в подсказке выводился полный путь к макросу? Или как сделать, чтобы при открытии окна редактирования макросов (через F11) все макросы в модулях отображались как папки в проводнике либо еще как-то, но чтобы их легко можно было найти?
Автор: Alex_Piggy
Дата сообщения: 06.02.2014 18:04
Доброе время, Romka_and_Tany
Посмотрите... Пример2.xlsm
Теперь понял задачу как отсортировать массив значений по возрастанию и вывести порядковый номер каждого числа.
Не понятно, из-за чего ноль иногда показывается как 0, иногда - как 1...

Добавлено: Пересчет всего листа ведь не нужен при изменении, верно?[more]

Код:
Private Sub Worksheet_Change(ByVal Target As Range)
If Target <> "" And (Target.Row Mod 2) Then Call RecalcValuesRow(Target.Row)
End Sub

Sub RecalcAll()
For Z = 1 To ActiveSheet.Cells(1, 1).End(xlDown).Row Step 2
RecalcValuesRow (Z)
Next Z
End Sub

Sub RecalcValuesRow(Row As Integer)
Dim Dict As New Scripting.Dictionary
Set Dict = New Scripting.Dictionary
Dict.RemoveAll
With Range(Cells(Row, 1), Cells(Row, 1).End(xlToRight))
Arr = .Value
For i = LBound(Arr, 2) To UBound(Arr, 2) - 1
For j = i + 1 To UBound(Arr, 2)
If Arr(1, i) > Arr(1, j) Then
Temp = Arr(1, j)
Arr(1, j) = Arr(1, i)
Arr(1, i) = Temp
End If
Next j
Next i

Dict.Add 0, 0
For Each Data In Arr
If Not Dict.Exists(Data) Then Dict.Add Data, Dict.Count
Next
Set OutRange = .Offset(1, 0)
For i = 0 To .Count - 1
If Not OutRange.Cells(1, i + 1).Value = Dict.Item(.Cells(1, i + 1).Value) Then OutRange.Cells(1, i + 1).Value = Dict.Item(.Cells(1, i + 1).Value)
Next i
End With
Set Dict = Nothing
End Sub
Автор: Silicoid
Дата сообщения: 06.02.2014 20:18
Посоветуйте касательно удаления строк через одну.
Почитав ветку, нашел следующее:

Цитата:
Sub DelRow()
Dim i%
For i = 21 To 1 Step -2
Rows(i).Delete
Next
End Sub

В моем понимании, здесь удаляются строки (через одну) с 21 по 1.
Как можно это модифицировать, чтобы черезстрочное удаление было не с конкретных строк, прописанных внутри скрипта, а из выделения на листе.

Допустим у меня лист с данными на 600-700 строк. В процессе ознакомления с документом я вижу, что мне нужно удалить с 47-ой по 93-ю строки. Я их выделяю, и этот скрипт удаляет внутри выделения каждую вторую строчку.
Как такое сделать?

Остаточные знания в программировании подсказывают мне, что нужно заменить в цикле числа 21 и 1, на переменные - допустим X и Y, где X - это первая строчка выделения, а Y последняя.

Какие команды возвращают эти значения для X и Y?
Автор: Alex_Piggy
Дата сообщения: 06.02.2014 21:21
Доброе время, Silicoid
Вы можете получить их как X = Selection.Row и Y = Selection.Row+Selection.Rows.Count. Наверное можно проще, но не знаю как.
А можете напрямую работать с выделением. Удаляет через строку начиная с последней строки выделения.

Код:
Sub DelRow()
For i = Selection.Rows.Count To 1 Step -2
Selection.Rows(i).Delete
Next
End Sub
Автор: Romka_and_Tany
Дата сообщения: 07.02.2014 10:35
Alex_Piggy, спасибо, что занялись вопросом.
Пересчет листа автоматически не нужен - ручной запуск.

То, что иногда 0 это 1 - виноват, сразу не уточнил - особенности оценки показателей.
Т.к. размерность таблицы фиксирована (меняется незначительно и редко) - прошу написать код, привязанный к конкретному статичному диапазону в строке - чтобы не обрабатывалась вся строка. Есть в таблице до и после оценочных данных ещё информация.
Тогда я смогу применять его только тем строкам, где оценка отлична от 0 и 1 и только к конкретному участку в строке. А если размерность таблицы изменится - подправить диапазон обработки в макросе - не долго.
Конечно, не так элегантно, но вроде бы проще реализовать?

Цитата:
Пример2.xlsm
- обрабатывает как и требовалось.



Автор: Alex_Piggy
Дата сообщения: 07.02.2014 16:42
Доброе время, Romka_and_Tany
В принципе - какая разница... Меняется буквально пара символов. С фиксированным диапазоном (сейчас - "A1:D3", задается в второй строке) будет так: [more]
Код:
Sub RecalcRowInRange()
Dim Dict As New Scripting.Dictionary
Set WorkRange = Range("A1:D3")
For Z = 1 To WorkRange.Rows.Count Step 2
With WorkRange.Rows(Z)
Dict.RemoveAll
Arr = .Value
For i = LBound(Arr, 2) To UBound(Arr, 2) - 1
For j = i + 1 To UBound(Arr, 2)
If Arr(1, i) > Arr(1, j) Then
Temp = Arr(1, j)
Arr(1, j) = Arr(1, i)
Arr(1, i) = Temp
End If
Next j
Next i
Dict.Add 0, 0
For Each Data In Arr
If Not Dict.Exists(Data) Then Dict.Add Data, Dict.Count
Next
Set OutRange = .Offset(1, 0)
For i = 0 To .Cells.Count - 1
If Not OutRange.Cells(1, i + 1).Value = Dict.Item(.Cells(1, i + 1).Value) Then OutRange.Cells(1, i + 1).Value = Dict.Item(.Cells(1, i + 1).Value)
Next i
End With
Next Z
Set Dict = Nothing
Set WorkRange = Nothing
End Sub
Автор: Romka_and_Tany
Дата сообщения: 08.02.2014 09:46
Alex_Piggy, спасибо Вам. Очень выручили.
Автор: tkachenkoser
Дата сообщения: 12.02.2014 15:10
Уже третий день шуршу инет не могу найти решение.
Необходимо в столбце поменять регистр букв (с заглавных на строчные) по маске (регулярному выражению).
Буду просто бесконечно благодарен за такой макрос.
Автор: Alex_Piggy
Дата сообщения: 12.02.2014 17:49
Доброе время, tkachenkoser
[more]

Код:
Option Explicit
Sub ChangeCase()
Const cRange = "A1:A45"
Dim objRegEx, tmpStr, oCell, oMatch
Set objRegEx = CreateObject("VBscript.regexp")
With objRegEx
.Global = True
.IgnoreCase = False
.MultiLine = False
.Pattern = "[A-Z]test"
End With
With ActiveSheet.Range(cRange)
For Each oCell In .Cells
If objRegEx.Test(oCell.Value) Then
tmpStr = oCell.Value
For Each oMatch In objRegEx.Execute(tmpStr)
tmpStr = Replace(tmpStr, oMatch.Value, LCase(oMatch.Value), 1, -1, vbBinaryCompare)
Next
oCell.Value = tmpStr
End If
Next
End With
End Sub
Автор: tkachenkoser
Дата сообщения: 12.02.2014 18:36
Большое спасибо, сейчас попробую.
Нет, не одну букву.
Условие такое - если слово больше чем из 3 букв, и не содержит цифры, и при этом оно не первое в строе - поменять на строчные.
РВ подходящее - [\S]([\D]{4,})
о результатах отпишусь.
Автор: Alex_Piggy
Дата сообщения: 12.02.2014 18:47
tkachenkoser
Или, может, "\s\D{4,}?\b" ?
Не могу придумать выражение нормальное. Нужна хотя бы одна заглавная буква для нормальной работы (не все слова заменять). Попробуйте еще "\s[^\s\d]*[A-Z][^\s\d]{3,}\b"

Автор: tkachenkoser
Дата сообщения: 14.02.2014 11:07
Alex_Piggy попробовал код.
Вылетает ошибка 400.
Проверял как на своем выражении, так и на "\s\D{4,}?\b",
Ecxel 2010.
Автор: Alex_Piggy
Дата сообщения: 14.02.2014 13:39
Доброе время, tkachenkoser
Не знаю. 2003 офис - работает. Посмотрите мой файл: Книга1.xls
Прошу прощения что на ifolder - DropBox нет доступа, rghost не открывается, а других навскидку не помню.
Автор: nicka
Дата сообщения: 20.02.2014 14:15
привет
есть xls файл, который рассчитывает вероятный счёт футбольного матча по статистике.
есть желание рассчитать с помощи этого файла вероятность угловых и карточек в предстоящем матче.

данная статистика хранится на сайтах типа livescore.com и myscore.ru

каким методом извлечь эту инфу на автомате? или полуавтомате?
и вбить в соответствующие поля в xls файле?
слышал о парсерах и о скриптах...
в каком направлении копать?
и вообще реально добытся этого без фундаментального знания веб-програмирования?
Автор: Silicoid
Дата сообщения: 20.02.2014 20:27
Все данные в таблице расположены в одном столбце "A". Данных много: 1000-1500 строк.
Все данные должные быть перепроверены в ручную, однако часть даных нужно скопировать в соседний столбец "B".
Простейший (в моём понимании) макрос должен помочь автоматизации этого рутинного труда.
Есть такой макрос.

Код: Sub Macros3()
Selection.Copy
Range("B6").Select
ActiveSheet.Paste
Application.CutCopyMode = False
End Sub
Автор: Alex_Piggy
Дата сообщения: 20.02.2014 22:08
Доброе время
nicka
Та в принципе нет... Что-то вроде можно. Только проверить завтра смогу. VBS точно работает, правда медленно...

Silicoid
Одна строка -
Selection.Offset(-1, 1).Value = Selection.Value
Автор: andrewkard1980
Дата сообщения: 02.03.2014 10:36
nicka
Добрый день.
Попробуйте так:

Код: sURL = "http://__________________________"
Set oHTTP = CreateObject("MSXML2.XMLHTTP")
With oHTTP
.Open "GET", sURL, False
.Send
sHTML = .responseText
End With
Set oHTTP = Nothing
Автор: Leojse
Дата сообщения: 04.03.2014 19:12
Добрый вечер. Помогите, пожалуйста, немного подредактировать макрос.

Код: Sub Hide()
For Each i In Selection
If CStr((i)) = "0" Then i.EntireRow.Hidden = 1
Next
Selection.SpecialCells(xlCellTypeBlanks).Select
Selection.EntireRow.Hidden = True
End Sub
Автор: Alex_Piggy
Дата сообщения: 04.03.2014 20:57
Доброе время, Leojse
Как Вы пробовали? У меня работает
If CStr((i)) = "0" OR CStr((i)) = "0/0" Then i.EntireRow.Hidden = 1
Автор: Leojse
Дата сообщения: 04.03.2014 21:19
Alex_Piggy
Спасибо! Всё работает. А я вместо OR вставлял AND, как-то про OR совсем не подумал.
Автор: DJMC
Дата сообщения: 18.03.2014 14:00
есть событие 1 и событие 2, нужно рассчитать самый частый исход между этими событиями на основе прежних результатов, всего два варианта...
[more=Пример..]http://vprognoze.ru/total_football.html[/more]    можно этот как то в exel прописать, чтобы не самому все считать?
Автор: Alex_Piggy
Дата сообщения: 18.03.2014 16:40
Доброе время, DJMC
Получение данных предыдущих матчей можно сделать и уже сделано для nicka.
Поэтому могу предложить/сделать только сам расчет по введеным вручную данным. Кстати, можно все - не на VB, а на функциях Excel.
Пример для значений диапазона A2:A16. Редактирование строки завершать не Enter, а Ctrl+Shift+Enter
Мода
=МОДА(ЗНАЧЕН(ЛЕВСИМВ(A2:A16;НАЙТИ(":";A2:A16)-1))+ЗНАЧЕН(ПСТР(A2:A16;НАЙТИ(":";A2:A16)+1;10)))
Среднее
=2*СРЗНАЧ(ЗНАЧЕН(ЛЕВСИМВ(A2:A16;НАЙТИ(":";A2:A16)-1));ЗНАЧЕН(ПСТР(A2:A16;НАЙТИ(":";A2:A16)+1;10)))
Автор: DJMC
Дата сообщения: 18.03.2014 18:11
Alex_Piggy
Большое спасибо!

А где было сделано для nicka? Можно ссылку?
Автор: Alex_Piggy
Дата сообщения: 19.03.2014 09:49
Доброе время, DJMC
Немного переделанное - test_DJMC.zip
Использует myScore.ru. В A1 вводите хэш матча по их системе (когда нажимаете на матч, открывается окно с URL вида "http://www.myscore.ru/match/OETxnpfk/#match-summary". Вот это OETxnpfk и вводите), затем нажимаете B1.
Автор: Leojse
Дата сообщения: 20.03.2014 21:13
Добрый вечер.
Снова прошу у Вас помощи. Подскажите, как написать макрос, который бы в выделенном диапазоне очищал ячейки, цвет шрифта которых белый? Пробовал макрорекордером, вот что получилось:

Код: Sub zapis'()
With Application.FindFormat.Font
.Subscript = False
.ThemeColor = 1
.TintAndShade = 0
End With
Selection.ClearContents
End Sub
Автор: AndVGri
Дата сообщения: 21.03.2014 03:46
Доброе время суток
Лучше так

Код:
Application.FindFormat.Font.Color = vbWhite
Cells.Replace What:="*", Replacement:=Empty, LookAt:=xlPart, SearchOrder _
:=xlByRows, MatchCase:=False, SearchFormat:=True, ReplaceFormat:=False

Страницы: 123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127

Предыдущая тема: VS 2010


Форум Ru-Board.club — поднят 15-09-2016 числа. Цель - сохранить наследие старого Ru-Board, истории становления российского интернета. Сделано для людей.