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

» Excel VBA (часть 3)

Автор: LaCastet
Дата сообщения: 21.05.2010 18:44
Hugo121
СПАСИБО!!!
Автор: bygor
Дата сообщения: 22.05.2010 16:58
Добрый день, возникла необходимость в переводе из числового значения в текстовый веса, найдена надстройка, которая справляеться с данной задачей
http://www.planetaexcel.ru/docs/forum_upload/post_109952.zip.
Но при работе выявилось, что сам результат длиннее, чем требуется и не помещается в указанные рамки.
Подскажите, как и чем отредактировать надстройку, что бы например: вместо килограмм выводило кг, тонн - тн.
Заранее благодарен
Автор: vlth
Дата сообщения: 22.05.2010 17:37
А зачем её редактировать? - Правка->Заменить...
Можете макрос записать.
Автор: andrewkard1980
Дата сообщения: 22.05.2010 19:02
Доброе время суток.
Уважаемые программисты, прошу о помощи. Столкнулся с такой ерундой. Хочу написать макрос, с помощью которого копируется html код странички в ячейку. Проблема в том, что на этом сайте бывает до 50 страниц, и я думал сделать так:
sURI = "http://.......=” & r & ”&i=” & n & ”&pg=1”
Set oHttp = CreateObject("MSXML2.XMLHTTP")
If Err.Number <> 0 Then
Set oHttp = CreateObject("MSXML.XMLHTTPRequest")
End If
On Error GoTo 0
If oHttp Is Nothing Then
Exit Sub
End If
oHttp.Open "GET", sURI, False
oHttp.Send
htmlcode = oHttp.responseText
On Error Resume Next
outstr = Mid(htmlcode, 1, InStr(1, htmlcode, "</HTML>"))
On Error Resume Next
Range("$M$1") = outstr

И так 50 раз, думаю что есть возможность упростить код через цикл, правда не знаю как
Подскажите. Спасибо

Добавлено:
Т.е. весь этот код для странички pg=1 в ячейку $M$1
весь для pg=2 в ячейку $M$2
и так 50 раз. Код получится очень большим.

Добавлено:
Вопрос снят. Все гениальное просто
Автор: bygor
Дата сообщения: 22.05.2010 20:06

Цитата:
[/q]
[q]А зачем её редактировать? - Правка->Заменить...
Можете макрос записать.

просто само расположение слов плавает, да и хотелось бы сделать на автомате
Автор: Hugo121
Дата сообщения: 22.05.2010 20:57
bygor, вот тут правьте:

Код: Sub СтройМат()
' Процедура группировки исходных элементов формируемой текстовой строки
'
...

тонны = Array("тонна", "тонны", "тонн")
килограммы = Array("килограмм", "килограмма", "килограммов")
граммы = Array("грамм", "грамма", "граммов")
Автор: bygor
Дата сообщения: 22.05.2010 21:06
Hugo121
[q][/q]
Я новичок, подскажите, чем открыть сам файл
Автор: Hugo121
Дата сообщения: 23.05.2010 00:03
bygor, гляньте в ящик...
Автор: chel78
Дата сообщения: 24.05.2010 07:30
Привет, помогите ламеру, хочу замутить макрос на скролирование мышкой, прицепить его на большую кнопку, и поместить в таблице, что бы при нажатии на эту кнопку, страница скролировалась, но не пойму как ..
что то наподобии этого.
---------------------
Sub ScrolDown5()
'
' ScrolDown5 Макрос
'

'
ActiveWindow.SmallScroll Down:=5
End Sub
----------------------

Но при выполнении этого макроса - скролит на 5 строк, надо все время кликать, а как так что бы нажать и держать..
сорри за ламерство
Автор: Hugo121
Дата сообщения: 24.05.2010 08:13
Поставьте на первый лист ToggleButton1:

Код: Option Explicit

Private Sub ToggleButton1_Click()
ScrolDown5
End Sub

Sub ScrolDown5()
'
' ScrolDown5 Макрос
'
If Sheets(1).ToggleButton1.Value = True Then
ActiveWindow.SmallScroll Down:=5
DoEvents
ScrolDown5
End If
End Sub
Автор: chel78
Дата сообщения: 24.05.2010 11:07

Цитата:
Поставьте на первый лист ToggleButton1:

Код:
Option Explicit

Private Sub ToggleButton1_Click()
ScrolDown5
End Sub

Sub ScrolDown5()
'
' ScrolDown5 Макрос
'
If Sheets(1).ToggleButton1.Value = True Then
ActiveWindow.SmallScroll Down:=5
DoEvents
ScrolDown5
End If
End Sub


не совсем есть понявший
Автор: Hugo121
Дата сообщения: 24.05.2010 11:59
Нажали баттон - перематывается, отжали - остановилось.
Я не знаю элемента управления, который может работать, как заказано.
Но может ещё OnMouseOver привлечь...

Добавлено:
Ну или так (что-то MouseOver не нашёл) - пока мышью елозишь по отжатому объекту - мотается:

Код: Private Sub ToggleButton1_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
If Sheets(1).ToggleButton1.Value = False Then
ActiveWindow.SmallScroll Down:=5
DoEvents
ScrolDown5
End If
End Sub
Автор: Booklet
Дата сообщения: 24.05.2010 15:33

Цитата:
Set blank_cell = xlsa.Cells(xlsa.[a1].SpecialCells(xlCellTypeLastCell).Row + 1, 1)

ммм... Определяем blank_cell как... Участок между А1 и LastCell и сдвигаемся вправо и вниз, так?

vlth
Да я без задней мысли спросил, чесслово.
... определяем три участка.
В участке с А1 по С4 если ошибка - то go.to
...определяем два участка... тут немного непонял, что в участки определяется*?

Далее как я понял, сравниваются содержимые...

ИМХО, не совсем то... Но есть над чем подумать.

Hugo121 после переноса макроса на другой комп почему-то снова полетело... Не те гриды, не увеличиваются высоты строк...
Автор: Hugo121
Дата сообщения: 24.05.2010 17:10
Вот, погоняйте по F8:

Код: Sub tt()
Set xlsa = ActiveSheet
Set blank_cell = xlsa.Cells(xlsa.[a1].SpecialCells(xlCellTypeLastCell).Row + 1, 1)
Debug.Print blank_cell.Address
Debug.Print xlsa.[a1].SpecialCells(xlCellTypeLastCell).Row
Set blank_cell = xlsa.Cells(3 + 1, 1)
Debug.Print blank_cell.Address
Set blank_cell = xlsa.Cells(4, 1)
Debug.Print blank_cell.Address
End Sub
Автор: vlth
Дата сообщения: 24.05.2010 20:29
Booklet, логика кода следующая:
Для ускорения получения объектной ссылки на поддиапазон из непустых ячеек,
которые могут содержать либо значение, вычисляемое с пом. формулы, либо какую-либо константу, используется свойство диапазона SpecialCells.
Т.е.
- если есть только константы - итоговый диапазон включает только такие ячейки;
- если есть только формулы - аналогично;
- если есть и те и те - их объединение.

Полученные в итоге таким образом ячейки обрамляются полужирной линией.

On error resume next - игнорируем ошибку, переходим к выполнению инструкций в след. строке кода

On error goto 0 - отменяем On error resume next.
Автор: rote92
Дата сообщения: 25.05.2010 12:33
Здравствуйте, знатоки VBA!

Есть задача: чтобы минимальное значение оси Х на обычном графике равнялось значению определенной ячейки. И послее изменения значения этой ячейки автоматически менялось бы и миним значение оси Х.

Сильно не пинайте - я только начал осваивать VB.
Заранее спасибо!
Автор: Ivan38Rus
Дата сообщения: 25.05.2010 13:50
Господа, помогите пожалуйста сделать программу лаконичней

Код: Option Explicit
Dim m As Integer
Dim n As Integer
Dim j As Integer
Dim i As Integer
Dim o As Integer
Dim v As Integer
Dim x As Integer
Dim y As Integer
Dim f As Single
Dim S As Single
Dim t As Single
Dim a() As Double
Private Sub CB1_Click()
m = 5: n = 7
ReDim a(1 To n, 1 To m)
For i = 1 To n
For j = 1 To m
a(i, j) = Cells(i, j).Value
Next j
Next i
S = a(1, 1): t = a(1, 1): o = 1: v = 1: x = 1: y = 1
For i = 1 To n
For j = 1 To m
If a(i, j) > S Then
S = a(i, j)
o = i
v = j
Else
End If
Next j
Next i
For i = 1 To n
For j = 1 To m
If a(i, j) < t Then
t = a(i, j)
x = i
y = j
Else
End If
Next j
Next i
f = 0
If v = y Then
j = v
If o < x Then
For i = o + 1 To x - 1
f = f + 1
Next i
Else
For i = x + 1 To o - 1
f = f + 1
Next i
End If
Else
If v > y Then
j = y
For i = x + 1 To n
f = f + 1
Next i
For j = y + 1 To v - 1
For i = 1 To n
f = f + 1
Next i
Next j
j = v
For i = 1 To o - 1
f = f + 1
Next i
Else
j = v
For i = o + 1 To n
f = f + 1
Next i
For j = v + 1 To y - 1
For i = 1 To n
f = f + 1
Next i
Next j
j = y
For i = 1 To x - 1
f = f + 1
Next i
End If
End If
MsgBox "Количество элементов между минимальным и максимальным равно " & f
MsgBox "Максимальное " & S
MsgBox "Минимальное " & t
End Sub
Автор: LaCastet
Дата сообщения: 25.05.2010 15:54
Как-то так


Код:
Option Explicit

Dim m As Integer
Dim n As Integer

Dim S As Single
Dim t As Single
Dim f As Single

Dim o As Integer
Dim v As Integer
Dim x As Integer
Dim y As Integer

Dim j As Integer
Dim i As Integer
Private Sub CB1_Click()
S = Cells(1, 1)
o = 1
v = 1

t = Cells(1, 1)
x = 1
y = 1

m = 5: n = 7

For i = 1 To n
For j = 1 To m
If Cells(i, j) > S Then
'Новый МАКСИМУМ
S = Cells(i, j)
o = i
v = j
ElseIf Cells(i, j) < t Then
'Новый МИНИМУМ
t = Cells(i, j)
x = i
y = j
End If
Next j
Next i

If v = y Then
If o < x Then
f = x - 1 - o
Else
f = o - 1 - x
End If
ElseIf v > y Then
f = n - x + n * (v - 1 - y) + o - 1
Else
f = n - o + n * (y - 1 - v) + x - 1
End If

MsgBox "Количество элементов между минимальным и максимальным равно " & f
MsgBox "Максимальное " & S
MsgBox "Минимальное " & t

End Sub
Автор: opelastr
Дата сообщения: 25.05.2010 21:09
Еще будет к вам вопрос:

Если нужно выполнить расчет A1*B1+A2*B2+A3*B3 формула будет такой:


Код:
For i = 1 To 3
S = S + Range("A" & i).Value * Range("B" & i).Value
Next i
Автор: Hugo121
Дата сообщения: 25.05.2010 22:12
Что-то я даже не понял:

Код: For i = 2 To 4
Автор: ferias
Дата сообщения: 25.05.2010 22:16
Поскольку i пересчитывает все строки то начните цикл с i=2
Автор: opelastr
Дата сообщения: 25.05.2010 22:18
Тупанул, просто стыдно.... Перезанимался.
Спасибо))
Автор: AllGoodWord
Дата сообщения: 26.05.2010 11:51
Приветствую уважаемый форум!
Подскажите - как правильно будет обойти всю некоторую прямоугольную таблицу построчно-поячейно.
То есть сердцем чую что алгоритмически организовать движение надо бы как то вот так примерно:

Код: Do While (выполнять пока строка NOT NULL)
Do While (выполнять пока ячейка NOT NULL)
If ячейка="" Then Exit
End If
Set ххх=ячейка содержимое
End Do
End Do
Автор: Hugo121
Дата сообщения: 26.05.2010 12:08
Что-то вроде такого работает:

Код: Sub tt()
x = 1
y = 1
Do While Cells(x, y) <> ""
x = x + 1
Do While Cells(x, y) <> ""
y = y + 1
If Cells(x, y) = "" Then
y = 1
Exit Do
End If
Cells(x, y).Select
Loop
Loop
End Sub
Автор: AllGoodWord
Дата сообщения: 26.05.2010 13:15
Пожалуй, два последних варианта неплохи. А последний - удобен, краток и вполне функционален...
Спасибо...
Автор: Pasha_new
Дата сообщения: 27.05.2010 08:18
А как правильно перевести этот скрипт для англ. версии?

Код: Sub Удалить()
Dim i As Long, EndRow As Long
i = ПерваяСтрока
EndRow = ПоследняяСтрока
Do Until i > EndRow
If InStr(1, Cells(i, 3), "part") Then
Cells(i, 3).Select
Selection.EntireRow.Delete
EndRow = EndRow - 1
End If
i = i + 1
Loop
End Sub
Автор: Hugo121
Дата сообщения: 27.05.2010 08:52
1. при удалении строк цикл надо пускать снизу вверх, а то будут неучтённые строки.
2. переводить скрипт не надо.
3. Select тут лишнее.
4. подкорректируйте значения ПерваяСтрока / ПоследняяСтрока, они судя по коду, задаются на стороне...

Код: Sub Удалить()
Dim i As Long
ПерваяСтрока = 1
ПоследняяСтрока = 15
For i = ПоследняяСтрока To ПерваяСтрока Step -1
If InStr(1, Cells(i, 3), "part") Then
If InStr(1, Cells(i, 3), "part1") = 0 Then
Rows(i).EntireRow.Delete
End If
End If
Next
End Sub
Автор: Pasha_new
Дата сообщения: 28.05.2010 00:20
Hugo121, огромное спасибо


Код: Dim strABC() As String
strABC = Split(Range("A1").Value, " ")
Range("B1") = strABC(0)
Автор: Drazhar
Дата сообщения: 28.05.2010 08:36
Pasha_new
Возник другой вопрос. Как из ячейки с числовым типом, сделать текстовый?

Это можно сделать например функцией CStr
Или скажем инкрементом ""то есть strvar=numvar & ""

Добавлено:
Pasha_new

Как загнать "A1" в цикл? Прописую Range(i,1) - выбивает ошибку
попробуй range(cells(i,1),cells(i,1))
мне обычно помогает
Автор: Solenaja
Дата сообщения: 28.05.2010 09:44
макрос

Код: Sub copy_sheets()
Dim arg As String, i As Integer, myPath As String
Application.ScreenUpdating = False
myPath = "E:\path\"
For i = 1 To Sheets.Count
arg = Sheets(i).Name
If Sheets(i).Tab.Color = RGB(0, 176, 80) Then
Sheets(Array("Один", "Пять", arg)).Copy
ActiveWorkbook.SaveAs myPath & arg & ".xls", FileFormat:=xlExcel8
ActiveWorkbook.Close
End If
Next
End Sub

Страницы: 123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127

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


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