» Excel VBA (часть 3)

Hugo121
СПАСИБО!!!

Добрый день, возникла необходимость в переводе из числового значения в текстовый веса, найдена надстройка, которая справляеться с данной задачей
http://www.planetaexcel.ru/docs/forum_upload/post_109952.zip.
Но при работе выявилось, что сам результат длиннее, чем требуется и не помещается в указанные рамки.
Подскажите, как и чем отредактировать надстройку, что бы например: вместо килограмм выводило кг, тонн - тн.
Заранее благодарен

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

Доброе время суток.
Уважаемые программисты, прошу о помощи. Столкнулся с такой ерундой. Хочу написать макрос, с помощью которого копируется 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 раз. Код получится очень большим.

Добавлено:
Вопрос снят. Все гениальное просто

Цитата:

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

просто само расположение слов плавает, да и хотелось бы сделать на автомате

bygor, вот тут правьте:

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

тонны = Array("тонна", "тонны", "тонн")
килограммы = Array("килограмм", "килограмма", "килограммов")
граммы = Array("грамм", "грамма", "граммов")

Hugo121
[q][/q]
Я новичок, подскажите, чем открыть сам файл

bygor, гляньте в ящик...

Привет, помогите ламеру, хочу замутить макрос на скролирование мышкой, прицепить его на большую кнопку, и поместить в таблице, что бы при нажатии на эту кнопку, страница скролировалась, но не пойму как ..
что то наподобии этого.
---------------------
Sub ScrolDown5()
'
' ScrolDown5 Макрос
'

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

Но при выполнении этого макроса - скролит на 5 строк, надо все время кликать, а как так что бы нажать и держать..
сорри за ламерство

Поставьте на первый лист 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

Цитата:

Поставьте на первый лист 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

не совсем есть понявший

Нажали баттон - перематывается, отжали - остановилось.
Я не знаю элемента управления, который может работать, как заказано.
Но может ещё 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

Цитата:

Set blank_cell = xlsa.Cells(xlsa.[a1].SpecialCells(xlCellTypeLastCell).Row + 1, 1)

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

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

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

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

Hugo121 после переноса макроса на другой комп почему-то снова полетело... Не те гриды, не увеличиваются высоты строк...

Вот, погоняйте по 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

Booklet, логика кода следующая:
Для ускорения получения объектной ссылки на поддиапазон из непустых ячеек,
которые могут содержать либо значение, вычисляемое с пом. формулы, либо какую-либо константу, используется свойство диапазона SpecialCells.
Т.е.
- если есть только константы - итоговый диапазон включает только такие ячейки;
- если есть только формулы - аналогично;
- если есть и те и те - их объединение.

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

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

On error goto 0 - отменяем On error resume next.

Здравствуйте, знатоки VBA!

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

Сильно не пинайте - я только начал осваивать VB.
Заранее спасибо!

Господа, помогите пожалуйста сделать программу лаконичней

Код: 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

Как-то так


Код:
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

Еще будет к вам вопрос:

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


Код:
For i = 1 To 3
S = S + Range("A" & i).Value * Range("B" & i).Value
Next i

Что-то я даже не понял:

Код: For i = 2 To 4

Поскольку i пересчитывает все строки то начните цикл с i=2

Тупанул, просто стыдно.... Перезанимался.
Спасибо))

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

Код: Do While (выполнять пока строка NOT NULL)
Do While (выполнять пока ячейка NOT NULL)
If ячейка="" Then Exit
End If
Set ххх=ячейка содержимое
End Do
End Do

Что-то вроде такого работает:

Код: 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

Пожалуй, два последних варианта неплохи. А последний - удобен, краток и вполне функционален...
Спасибо...

А как правильно перевести этот скрипт для англ. версии?

Код: 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

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

Hugo121, огромное спасибо


Код: Dim strABC() As String
strABC = Split(Range("A1").Value, " ")
Range("B1") = strABC(0)

Pasha_new
Возник другой вопрос. Как из ячейки с числовым типом, сделать текстовый?

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

Добавлено:
Pasha_new

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

макрос

Код: 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