» Excel VBA (часть 2)

5tas
Лучше всего создать класс и в модуле этого класса прописать процедуру.
Пример

Приветствую!
Есть столбец ячеек с гиперссылками,
Как рядом получить столбец текста (адреса) гиперссылок для всех ячеек (например http://forum.ru-board.com)?

В нете нашел код макроса, который должен это делать, но при его запуске excel выдает ошибку: "Expected: Ens Sub"

Как её исправить?

Сам код:

Sub Макрос1()
Function textH(oCell) As String
Dim s$
On Error GoTo Exit_
s = oCell.Hyperlinks(1).Address
If Len(s) > 0 Then textH = s
Exit_:
End Function
End Sub

SAS888
Вы немного неправильно меня поняли. Кнопки находятся не на форме, а на самом листе.
Должно быть что-то по аналогии с вашим примером:

Код: For Each ctl In UserForm1.Controls
...
Next

5tas
А какие кнопки Вы использовали?
Из панели "Элементы управления" или "Формы"?

SAS888
Я использовал кнопки из панели "элементы управления".

Уважаемые мастера.

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

Sheets(SourceSheet).Copy After:=Sheets(Sheets.Count)
ActiveSheet.Name = TargetSheet

При таком копировании получается, что все диаграммы берут данные из таблицы исходного листа.
Как это побороть?

Хочу отметить, что если копию листа создавать вручную через пункт меню переместить/скопировать, то ссылки в диаграмме на листе копии корректно обновляются...

Заранее спасибо за помощь!

Всем привет! У меня вопрос. Можно ли написать макрос экспортирующий из листа excel отдельное изображение не диаграмму в файл .JPG или .GIF? Скажем вставленный ранее рисунок или автофигуру?

RanderX

Цитата:

Есть лист экселя с таблицей данных и построенной над ней диаграммой.
Макросом создается несколько десятков копий данного листа.

Sheets(SourceSheet).Copy After:=Sheets(Sheets.Count)
ActiveSheet.Name = TargetSheet

При таком копировании получается, что все диаграммы берут данные из таблицы исходного листа.
Как это побороть?

Любопытно. Сейчас попробовал на примере простой круговой диаграммы. Нет такого эффекта как у вас. Все копируется как надо и вручную и программно. Excel 2003.

Может у вас источник данных для диаграммы тоже задается программно, и при этом не совсем правильно?

anienioni
Нет. данные статические.
Вернее диаграмма ссылается на фиксированные строки, заполненные другим макросом.

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

Решение - создал скрытые строки (подряд согласно последовательности отображаемых данных), ссылающиеся на строки с данными и уже над ними построил диаграмму.

Все работает...

Проблема может и не совсем VBA но именно она мешает написать макрос.

Имеем Excel 2007. Ячейка с числом, допустим А1 содержит число 153.
Задача: сделать содержимое текстом.

Что делаю:
1. Формат ячейки/Текстовый
2. В соседнюю B1 вписываю формулу =А1+1
результат в ячейке B1: 154! Т.е. содержимое А1 не становится текстом, и только после того как я войду-выйду в ячейку А1, её содержимое наконец-то становится текстом!

Как исправить ситуацию?
================================
...не знаю как эту, но свою проблему решил: при вставке из массива число вставляется в ячейку как число, не смотря на текстовый формат ячейки. Изменил массив на текстовый и всё заработало.

Подскажите, плиз, есть некая функция, если передавать в качестве параметра непосредственно ячейку =function1(a1), то все отлично работает, а вот если псевдоним столбца =function1(name_st), то идет ошибка #ЗНАЧ!. Как передавать функции псевдоним?

Roka
Во-первых, может ли эта функция работать со столбцом?
Во-вторых, если, например, функция задана, как
Код: Function Function1(x As Range)

Цитата:

SAS888

собственно вот код
Public Function TextToNumber(t As String)
TextToNumber = ""
If t <> "" Then
For i = 1 To Len(t)
If Asc(Mid(t, i, 1)) >= 48 And Asc(Mid(t, i, 1)) < 58 Then
TextToNumber = TextToNumber & Mid(t, i, 1)
End If
Next i
End If
TextToNumber = Val(TextToNumber)
End Function

Roka
И что? Параметр функции - строковая переменная t.
Что Вы хотите? При чем здесь столбец?

Roka, а зачем такую сложную функцию рисовать? Обычный

Val(Replace(Str, ".", ","))

Работает прекрасно Правда, если ВНУТРИ числа предполагается наличие "посторонних" символов, VAL() отработает некорректно. Но другое дело - тебе действительно надо конвертировать в число строку, в которой точно не только число содержится? И зачем в число "переносимых" символов включать двоеточие (CHR(58))?

Может раскрой нам ТЗ, а мы присоветуем Предсказываю, что все закончится тем, что автора устроит формула

=If(IsError(Value(A1));0;Value(A1))

Цитата:

ZlydenGL

Имеется столбец, в котором внесены определенные значения, из них требуется извлечь, только числа. Данные вносятся вручную, поэтому символы меж чисел попадаются разные.
Replace хорошо, но не универсально.
Функция та, что я привел работает отлично, если в качестве параметра передавать ячейку.
Данную бяку дальше использую в формулах в разных excel-файлах, но с одинаковыми псевдонимами столбцов, поэтому и хочется чтобы в параметре был не a1, a2, а псевдоним, как это в стандартных функциях Excel можно записать не как =a1+b1, а =kod+mod

Roka, в любом случае советую учесть 2 момента:

1. Двоеточие твой код все-таки не уберет
2. Если тебе передадут число 123.45 (т.е. сто двадцать три целых сорок пять сотых), то на выходе своей функции ты получишь ДВЕНАДЦАТЬ ТЫСЯЧ триста сорок пять. Точность устраивает?

Соответственно доработка:
Public Function TextToNumber(tt)
If TypeName(tt) = "Range" Then
t = tt.text
Else
t = tt
End If
TextToNumber = ""
If t <> "" Then
For i = 1 To Len(t)
If IsNumeric(Mid(t, i, 1)) Or Mid(t, i, 1)="." Then
TextToNumber = TextToNumber & Mid(t, i, 1)
End If
Next i
End If
TextToNumber = Val(TextToNumber)
End Function

Таким образом:
1. На вход процедуры можно подавать не только число, но и ячейку (только нет обработчика, что делать, если на вход по ошибке подан ДИАПАЗОН ячеек)
2. Двоеточие не будет включено в результирующее число
3. Нормально будет обработана десятичная часть (если в качестве разделителя используется точка, хотя можно и добавить условие для проверки на запятую. Но в этом случае будет траббл, если допустим используется точка как разделитель десятичной записи, а запятая - в качестве разделителя порядков, т.е. допустим 123,456.79).

Еще раз удачи

P.S. В VBA совсем необязательно обнулять переменные, поскольку по дефолту переменная является локальной и создается с нулевым (пустым) значением сразу после первого объявления.
P.P.S. Вообще первая правка в принципе и не нужна - именованная область должна нормально отрабатывать в качестве параметра, если тип параметра - Variant. Я ее на всякий случай докрутил

Помогите дописать макрос
Добрый день,помогите пожалуйста с макросом
имеется список из шести столбцов:

ФИО менеджера l e-mail менеджера l e-mail сотрудника l ФИО сотрудника l телефон сотрудника l $

иванов | ivanov | petrov | Петров | 9854312313 |10
солнцев | solncev | trubin | Трубин | 9856783512 |30
иванов | ivanov | erofeev | Ерофеев | 9858732095 |18



те у сотрудника ерофеева и петрова начальник Иванов - ему надо отправить сообщение что:
Петров 9854312313 10
Ерофеев 9858732095 18
Итог 28



$ - деньги которые потратил сотрудник на связь
левая колонка менеджер - его подчиненые в столбце ФИО сотрудника
у нескольких сотрудников может быть один менеджер - то есть фамилии в столбце ФИО менеджера
Помогите написать макрос,который считает сколько денег потратили сотрудники и отправляет сообщение менеджеру со списком его подчиненных их номерами телефонов и суммой счетов

имеется макрос тупо рассылки по номерам сотрудников(из таблицы Excel) - который дописывает @mail к столбцу email сотрудника и присылает им сообщение сколько они потратили на связь - помогите пожалуйста его изменить.

Идем сверху находим имя менеджера - находим для его сотрудников формируем список сотрудников с их телефонами и деньгами за свзяь - считаем сумму и отсылаем менеджеру - то есть начальнику=менеджеру

слева менеджеры - справа сотрудники

Peen, ты бы хоть вызов и параметры этого макроса рассылки приложил (а еще лучше - его исходник), чтобы знать, как формировать строку параметров для него

с логикой определился - а как все правильно описать - вот в чем вопрос

1)Поиск по ФИО менеджера одинаковых значений
2)Формируем из них массив со списком для каждого менеджера - список его сотрудников с подсчетом суммы разговоров+формируем сообщение с таблицей его подчиненных их телефонами и деньгами
3)рассылка по менеджерам


в исходном виде:

Sub SendEMail_via_CDO()

Dim iMsg As Object
Dim iConf As Object
Dim strbody As String

'add NameSVColumn;EmailSVIDColumn

Dim NameSVColumn As String
Dim EmailSVIDColumn As String
Dim NameColumn As String
Dim EmailIDColumn As String
Dim PhoneColumn As String
Dim AmountColumn As String
Dim DataStartRow As Integer
Dim ReportMonth As String
Dim ReportYear As String
Dim SRow As Long
Dim Flds As Variant


totCustomer = 0

On Error GoTo err_SendEMail_via_CDO

'Check whether the user is connected to the Network, else show an error msg
If IsConnected = True Then
Else
MsgBox "You can't use this subroutine because you are not connected to Network.", vbCritical
End If

Set iConf = CreateObject("CDO.Configuration")

iConf.Load -1 ' CDO Source Defaults
Set Flds = iConf.Fields
With Flds
.Item("http://schemas.microsoft.com/cdo/configuration/sendusing") = 2
'.Item("http://schemas.microsoft.com/cdo/configuration/smtpserver") = "smtpam.shell.com"
.Item("http://schemas.microsoft.com/cdo/configuration/smtpserver") = "smtp-ea.services.shell.net"
.Item("http://schemas.microsoft.com/cdo/configuration/smtpserverport") = 25
.Update
End With





NameSVColumn = cbonamesvcol.Text
EmailSVIDColumn = cboemailsvidcol.Text
NameColumn = cbonamecol.Text
EmailIDColumn = cboemailidcol.Text
PhoneColumn = cbophonecol.Text
AmountColumn = cboamtcol.Text
DataStartRow = cboDatastartRow.Text
ReportMonth = cbomonth.Text
ReportYear = cboyear.Text
Application.Cursor = xlWait

For SRow = DataStartRow To MaxRow
If Range(EmailIDColumn & SRow & ":" & EmailIDColumn & SRow) = "" Then Exit Sub

strbody = "mobile phone / &#236;&#238;&#225;&#232;&#235;&#252;&#237;&#251;&#233; &#242;&#229;&#235;&#229;&#244;&#238;&#237;" & Chr$(10) & "----------------------------------------------------" & Chr$(10)
strbody = strbody & " " & Range(PhoneColumn & SRow & ":" & PhoneColumn & SRow) & " (" & Range(NameColumn & SRow & ":" & NameColumn & SRow) & ")" & Chr$(10)
strbody = strbody & " " & Range(EmailIDColumn & SRow & ":" & EmailIDColumn & SRow) & Trim(txtTosuffix.Text) & Chr$(10) & Chr$(10)
strbody = strbody & "monthly expenses / &#231;&#224;&#242;&#240;&#224;&#242;&#251; &#231;&#224; &#236;&#229;&#241;&#255;&#246;" & Chr$(10) & "--------------------------------------------------------" & Chr$(10)
strbody = strbody & " " & ReportMonth & "." & ReportYear & Chr$(10)
strbody = strbody & " $" & Range(AmountColumn & SRow & ":" & AmountColumn & SRow) & " USD" & Chr$(10)
strbody = strbody & Chr$(10) & "(&#240;&#243;&#241;&#241;&#234;&#232;&#233; &#242;&#229;&#234;&#241;&#242; &#241;&#235;&#229;&#228;&#243;&#229;&#242; &#231;&#224; &#224;&#237;&#227;&#235;&#232;&#233;&#241;&#234;&#232;&#236;)" & Chr$(10)
strbody = strbody & Chr$(10) & txtEmailBody_Eng.Text & Chr$(10) & Chr$(10) & "---------------------------------------------------------------------------------------------------------------------------------------------------------" & Chr$(10) & Chr$(10) & txtEmailBody_Rus.Text & Chr$(10)

Set iMsg = CreateObject("CDO.Message")

With iMsg
Set .Configuration = iConf
.From = txtFromMailID.Text
.To = Range(EmailIDColumn & SRow & ":" & EmailIDColumn & SRow) & Trim(txtTosuffix.Text)
.CC = ""
.BCC = ""
.Subject = "(" & Range(PhoneColumn & SRow & ":" & PhoneColumn & SRow) & ") " & Trim(txtSubject.Text)
.TextBody = strbody
.Send
End With
totCustomer = totCustomer + 1

Set iMsg = Nothing
DoEvents
Next

Set iConf = Nothing

Application.Cursor = xlDefault
Exit Sub

err_SendEMail_via_CDO:
MsgBox "Error while sending e-mails via CDO.", vbCritical
Application.Cursor = xlDefault
End Sub

Peen, ты бы хоть под кат код спрятал, а то сообщение получилось ОЧЕНЬ длинным

Насчет логики: а наличие менеджеров-однофамильцев исключено? Как и то, что один менеджер фигурирует с ДВУМЯ адресами электронной почты? Насчет логики программирования и определяться не с чем - алгоритм-то достаточно прост Например - зафигачить все данные в массив, отсортировать его по фамилии менеджера, а потом скользить по списку вниз. Как только фамилия менеджера сменилась - накопленный пул данных отправляем прежнему менеджеру, пул обнуляем, и запоминаем нового менеджера. Все! Причем сортировку можно даже не в массиве, а на листе Excel'я делать. Но при этом надо убедиться в вышеописанных потенциальных косяках.

ZlydenGL


Цитата:

Насчет логики: а наличие менеджеров-однофамильцев исключено? Как и то, что один менеджер фигурирует с ДВУМЯ адресами электронной почты? Насчет логики программирования и определяться не с чем - алгоритм-то достаточно прост Например - зафигачить все данные в массив, отсортировать его по фамилии менеджера, а потом скользить по списку вниз. Как только фамилия менеджера сменилась - накопленный пул данных отправляем прежнему менеджеру, пул обнуляем, и запоминаем нового менеджера. Все! Причем сортировку можно даже не в массиве, а на листе Excel'я делать. Но при этом надо убедиться в вышеописанных потенциальных косяках.

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


Изучал VB давно,с написанием хромает,можешь накидать формирование массива,сортировка и формирование затрат на связь.Буду очень признателен

Йэх... Попробую сначала описать, как бы я подобную задачу писал

1. Написал бы ОТДЕЛЬНУЮ процедуру, которая отправляет ПРОИЗВОЛЬНЫЙ контент на указанное мыло. Что-то вроде этого:


Код: Public Sub SendEMail(SendFrom as String, SendTo As String, Subject As String, Body As String, Conf As String)
Dim iMsq As Object
Set iMsg = CreateObject("CDO.Message")
With iMsg
Set .Configuration = Conf
.From = SendFrom
.To = SendTo
.CC = ""
.BCC = ""
.Subject = Subject
.TextBody = Body
.Send
End With
End Sub

самый основной вопрос - как подсчитать кол-во менеджеров и к ним привязать их сотрудников - вот в чем соль то

Peen, в исходном ТЗ не увидел ни слова про кол-во менагеров - поясни, на кой еж оное тебе сплющилось? Если все-таки критично, то последняя процедура будет выглядеть так:


Код: Sub SendManagerReport()
Dim MName As String, Body As String, MCount as Integer
ActiveSheet.UsedRange.Sort Key1:=Range("A2"), Header:=xlYes
MName = Cells(1, 1)
For I = 2 To UsedRange.Cells.xlLastCell.Row
If Not Cells(I, 1) = MName Then
SendEMail(txtFromMailID.Text, Cells(I,2) & "@mail.ru", "Some Subject", Body)
MName = Cells(I, 1)
Body = ""
MCount = MCount + 1
End If
For J = 4 To 6
Body = Body & Cells(1,J) & ": " & Cells(I,J) & vbNewLine
Next J
Next I
End Sub

SendEMail(txtFromMailID.Text, Cells(I,2) & "@mail.ru", "Some Subject", Body)
выделяет красным

сам смысл состоит в том что бы в сообщение,кторое будет отправлено вносился список его соотрудников с их данными

Peen, сама процедура есть? Попробуй ее без скобок вызывать, т.е. так:
SendEMail txtFromMailID.Text, Cells(I,2) & "@mail.ru", "Some Subject", Body

так немного конкретнее

есть значения:
ФИО менеджеров | e-mail manager | e-mail сотрудника | ФИО сотр | тел сотр | $

как написать массив который:
перебирает значения ФИО менеджеров и для повторяющихся >=2 раз менеджеров формирует список подчиненных(сотрудников) по вот таким данным:
e-mail сотрудника | ФИО сотр | тел сотр | $


p.s.может соеденить горизотально ячейки : e-mail сотрудника | ФИО сотр | тел сотр | $
методом Union?

Peen, опять же - но проблемо


Код: Sub SendManagerReport()
Dim MName As String, Body As String, MCount as Integer
ActiveSheet.UsedRange.Sort Key1:=Range("A2"), Header:=xlYes
MName = Cells(1, 1)
For I = 2 To UsedRange.Cells.xlLastCell.Row
If Not Cells(I, 1) = MName Then
If MCount>1 Then SendEMail(txtFromMailID.Text, Cells(I,2) & "@mail.ru", "Some Subject", Body)
MName = Cells(I, 1)
Body = ""
MCount = MCount + 1
End If
For J = 3 To 6
Body = Body & Cells(1,J) & ": " & Cells(I,J) & vbNewLine
Next J
Body = Body & vbNewLine & "-------------------------------"
Next I
End Sub

Имеется такой массив



Sub SelectionFind2()
Dim y As Integer, z As New Collection, mass2() As String, b()
b = Sheets("Sheet1").[A1:A1000].Value: ReDim mass2(1 To 1)
For y = 1 To UBound(b, 1)
If b(y, 1) <> "" Then ' &#228;&#229;&#235;&#224;&#229;&#236; &#241;&#241;&#251;&#235;&#234;&#243; &#237;&#224; &#241;&#238;&#242;&#240;&#243;&#228;&#237;&#232;&#234;&#238;&#226;?
On Error Resume Next: z.Add b(y, 1), CStr(b(y, 1))
If Err = 0 Then
mass2(UBound(mass2)) = b(y, 1): ReDim Preserve mass2(1 To UBound(mass2) + 1)
Else: On Error GoTo 0
End If
End If
Next
For y = 1 To 1000
Cells(y, 5).Value = mass2(y)
Next y

ReDim Preserve mass2(1 To UBound(mass2) - 1)
End Sub


Выбирает значения в единственном экземпляре и вставляет рядом в колонку,но выдает предупреждение:"subscript out of range" - почему?

хотелось бы его переделать для того что бы он перебирал значения ФИО менеджеров и для повторяющихся >=2 раз менеджеров формирует список их подчиненных(сотрудников) по вот таким данным:
e-mail сотрудника | ФИО сотр | тел сотр | $