TXP
выбор области с определенного листа
Sheets("Аннуитет").Range(...
выбор области с определенного листа
Sheets("Аннуитет").Range(...
» Excel VBA (часть 3)
Цитата:
TXP
выбор области с определенного листа
Sheets("Аннуитет").Range(...
С этим разобрался, спасибо
TXP
Цитата:
[more=без перехода на лист]
Код: Sub Действие1(Sh As Worksheet)
MsgBox "Действие1 на листе " & Sh.Name
End Sub
Sub Действие2(Sh As Worksheet)
MsgBox "Действие2 на листе " & Sh.Name
End Sub
Sub a()
Select Case Range("A1").Value
Case 2
Call Действие1(Sheets("Лист2"))
Case 3
Call Действие2(Sheets("Лист3"))
End Select
End Sub
Цитата:
И по возможности если не затруднит, пропишите команду для выбора конкретного листа и конкретного действия на нем, т.е. если в ячейке "А1" указано "2" то перейти на лист "Такойто1" и выполнить "Действие1", если указанно "3" то перейти на лист "Такойто2" и выполнить "Действие2"
[more=без перехода на лист]
Код: Sub Действие1(Sh As Worksheet)
MsgBox "Действие1 на листе " & Sh.Name
End Sub
Sub Действие2(Sh As Worksheet)
MsgBox "Действие2 на листе " & Sh.Name
End Sub
Sub a()
Select Case Range("A1").Value
Case 2
Call Действие1(Sheets("Лист2"))
Case 3
Call Действие2(Sheets("Лист3"))
End Select
End Sub
Бальшое спасибо, с тем что не работало я разобрался сам (я не указал лист для ячейки Q9).
Доброго дня!
Вопрос в следующем. К примеру, имеются такие данные: по ячейкам строки
Фамилия 1, баллы за 1 контрольную, баллы за 2 контр., ... баллы за n контр.
....
Фамилия n, баллы за 1 контрольную, баллы за 2 контр., ... баллы за n контр.
Так вот, как можно вывести диалоговое окно пользователю с возможностью выбора из списка существующих в файле фамилий. Выбираем фамилию, далее строится график по баллам каждой контрольной. Типа как график успеваемости своеобразный. Ну с графиком разберусь, а вот как средствами VBA вывести запрос с использованием заданного списка, непонятно совсем. Подскажите, куда копать, если кто сталкивался или может есть код готовый.
Заранее спасибо!
Вопрос в следующем. К примеру, имеются такие данные: по ячейкам строки
Фамилия 1, баллы за 1 контрольную, баллы за 2 контр., ... баллы за n контр.
....
Фамилия n, баллы за 1 контрольную, баллы за 2 контр., ... баллы за n контр.
Так вот, как можно вывести диалоговое окно пользователю с возможностью выбора из списка существующих в файле фамилий. Выбираем фамилию, далее строится график по баллам каждой контрольной. Типа как график успеваемости своеобразный. Ну с графиком разберусь, а вот как средствами VBA вывести запрос с использованием заданного списка, непонятно совсем. Подскажите, куда копать, если кто сталкивался или может есть код готовый.
Заранее спасибо!
StalkerI
Добавляете форму и на нее набрасываете Combobox и кнопку.
На инициализацию формы ставите наполнение комбика из range(через listfillrange).
А дальше уже разберетесь.
Добавляете форму и на нее набрасываете Combobox и кнопку.
На инициализацию формы ставите наполнение комбика из range(через listfillrange).
А дальше уже разберетесь.
Каким макросом можно найти в столбце пустые ячейки и скопировать в каждую из них содержание, предыдущей им заполненной ячейки? Да. Перебор нужно прекратить на предпоследней заплненной ячейке столбца. Иначе макрос забьет данными весь лист донизу
JekG
Для решения Вашей задачи совсем не обязательно перебирать все ячейки и сравнивать их на пустоту. Достаточно, например, для столбца "A", выполнить следующий код:
Код: Dim x As Range, y As Range: On Error Resume Next
Set x = Range([A2], Cells(Rows.Count, 1).End(xlUp))
Set y = x.SpecialCells(xlCellTypeBlanks)
y = "=R[-1]C": x.Value = x.Value
Для решения Вашей задачи совсем не обязательно перебирать все ячейки и сравнивать их на пустоту. Достаточно, например, для столбца "A", выполнить следующий код:
Код: Dim x As Range, y As Range: On Error Resume Next
Set x = Range([A2], Cells(Rows.Count, 1).End(xlUp))
Set y = x.SpecialCells(xlCellTypeBlanks)
y = "=R[-1]C": x.Value = x.Value
SAS888
Цитата:
Здорово, только у меня табличка с большим количеством столбцов, в которых забиты данные по ФИО. Можно ли написать код так, чтобы он вначале выделял область А4:BS2200, и сортировал все эти данные по столбцу Е (в нём стоят ФИО). А исходное значение исправленной записи выводил в столбце не В, а BT?
Добавлено:
И я заметил, что во всех ФИО после И стоит пробел перед О, можно ли его убрать, чтобы между И и О была только точка без пробела?
Добавлено:
Ещё маленький нюанс: в Вашем примере есть такой Уткин Н. После выполнения макроса в столбцах А и В стоят одинаковые ФИО: "Уткин Н." Т,е. до макроса был Уткин Н без точки после имени, после макроса - появилась точка. Как я понимаю, в столбце В должен появиться вариант до макроса, т.е. без точки? И смотря на разницу между столбцами А и В, я могу видеть - ага, вот что здесь испарвил макрос: добавил точку.
На данный момент получается, что если в стобцах А и В стоят одинковые ФИО, значит макрос ничего существенно в ФИО не изменял, а привёл ФИО в надлежащий вид: убрал лишние пробелы и поставил где нужно точки. Я правильно понимаю?
Если правильно, то это даже лучше, т.к. можно пройтись по всему столбцу В, и через ИСТИНА отсоритровать такие моменты, в которых данные были не существенно изменены, и работать только с теми ФИО, в которые макрос привнёс существенные изменения.
Цитата:
Макрос пронормирует все записи в столбце "A" и добавит недостающие инициалы в том случае, если найдется такая же фамилия с полными инициалами. В столбце "B", напротив исправленной ячейки будет выведено исходное значение исправленной записи. Это и будет меткой для визуального контроля
Здорово, только у меня табличка с большим количеством столбцов, в которых забиты данные по ФИО. Можно ли написать код так, чтобы он вначале выделял область А4:BS2200, и сортировал все эти данные по столбцу Е (в нём стоят ФИО). А исходное значение исправленной записи выводил в столбце не В, а BT?
Добавлено:
И я заметил, что во всех ФИО после И стоит пробел перед О, можно ли его убрать, чтобы между И и О была только точка без пробела?
Добавлено:
Ещё маленький нюанс: в Вашем примере есть такой Уткин Н. После выполнения макроса в столбцах А и В стоят одинаковые ФИО: "Уткин Н." Т,е. до макроса был Уткин Н без точки после имени, после макроса - появилась точка. Как я понимаю, в столбце В должен появиться вариант до макроса, т.е. без точки? И смотря на разницу между столбцами А и В, я могу видеть - ага, вот что здесь испарвил макрос: добавил точку.
На данный момент получается, что если в стобцах А и В стоят одинковые ФИО, значит макрос ничего существенно в ФИО не изменял, а привёл ФИО в надлежащий вид: убрал лишние пробелы и поставил где нужно точки. Я правильно понимаю?
Если правильно, то это даже лучше, т.к. можно пройтись по всему столбцу В, и через ИСТИНА отсоритровать такие моменты, в которых данные были не существенно изменены, и работать только с теми ФИО, в которые макрос привнёс существенные изменения.
Помогите, пожалуйста!
Задача: В колонке названия организаций. В одной ячейке может быть несколько организаций. Нужно закрыть кавычку в названии организации, если ее нет.
Макрос идет по колонке и проверяет значение ячейки. Если кавычек нечетное количество, в конце значения ставит кавычку.
Написала макрос, проверяю в пошаговом режиме - работает быстро, все считает! Запускаю RUN виснет весь Excel. Значений несколько тысяч, а он и 10 штук считает около получаса.
Почему это происходит? Как это исправить?
Задача: В колонке названия организаций. В одной ячейке может быть несколько организаций. Нужно закрыть кавычку в названии организации, если ее нет.
Макрос идет по колонке и проверяет значение ячейки. Если кавычек нечетное количество, в конце значения ставит кавычку.
Написала макрос, проверяю в пошаговом режиме - работает быстро, все считает! Запускаю RUN виснет весь Excel. Значений несколько тысяч, а он и 10 штук считает около получаса.
Почему это происходит? Как это исправить?
Lilu1
Цитата:
а где текст макроса в котором это происходит?
Цитата:
Почему это происходит? Как это исправить?
а где текст макроса в котором это происходит?
Требуется помощь.
Имеется книга с несколькими листами: Файл
Нужен макрос, который бы проверял совпадение человека с листа1 в списке на листе2. Если человек найден, то добавить в определенную ячейку на листе2, а если не найден то выводить стоку на лист3.
Т.е. должны проверяться несколько ячеек одновременно с первого листа со всем списком на втором листе (вроде бы примерно так).
Имеется книга с несколькими листами: Файл
Нужен макрос, который бы проверял совпадение человека с листа1 в списке на листе2. Если человек найден, то добавить в определенную ячейку на листе2, а если не найден то выводить стоку на лист3.
Т.е. должны проверяться несколько ячеек одновременно с первого листа со всем списком на втором листе (вроде бы примерно так).
Sub Макрос2()
'
' Макрос2 Макрос
' Макрос записан 29.10.2010 (ACER-BOOK)
'
Dim st, st1 As String
Dim n, n1 As Integer
Dim wbk As Workbook
Set wbk = Application.ActiveWorkbook
st = """"
For i = 10 To 20 'надо 5 000- диапазон сравнения
n = 0
st1 = wbk.Sheets("лист2").Cells(i, 2)
n1 = InStr(1, st1, st, 1)
If n1 <> 0 Then
While n1 <> 0
n = n + 1
n1 = InStr(n1 + 1, st1, st, 1)
Wend
End If
wbk.Sheets("лист2").Cells(i, 27) = n
If n <> 0 And n Mod 2 <> 0 Then
st1 = st1 + st
wbk.Sheets("лист2").Cells(i, 2) = st1
End If
Next i
End Sub
'
' Макрос2 Макрос
' Макрос записан 29.10.2010 (ACER-BOOK)
'
Dim st, st1 As String
Dim n, n1 As Integer
Dim wbk As Workbook
Set wbk = Application.ActiveWorkbook
st = """"
For i = 10 To 20 'надо 5 000- диапазон сравнения
n = 0
st1 = wbk.Sheets("лист2").Cells(i, 2)
n1 = InStr(1, st1, st, 1)
If n1 <> 0 Then
While n1 <> 0
n = n + 1
n1 = InStr(n1 + 1, st1, st, 1)
Wend
End If
wbk.Sheets("лист2").Cells(i, 27) = n
If n <> 0 And n Mod 2 <> 0 Then
st1 = st1 + st
wbk.Sheets("лист2").Cells(i, 2) = st1
End If
Next i
End Sub
Lilu1
Тормозит из-за "прямой" работы с ячейками, попробуйте так
[more]
Код:
'Подключить Microsoft VBScript Regular Expressions 5.5
'onSheet рабочий лист, на котором расположенны данные
'inCol номер столбца на рабочем листе с анализируемыми ячейками
'outCol номер столбца, куда выводиться число кавычек в анализуруемых ячейках
'fristRow номер первой строки с данными на рабочем листе
'lastRow номер последней строки с данными на рабочем листе
Public Sub AddQuotes(ByVal onSheet As Excel.Worksheet, ByVal inCol As Long, _
ByVal outCol As Long, ByVal firstRow As Long, ByVal lastRow As Long)
Const charQuote As String = """"
Dim pReg As New VBScript_RegExp_55.RegExp
Dim pResult As VBScript_RegExp_55.MatchCollection
Dim vData As Variant, pRange As Excel.Range
Dim vCount() As Long, i As Long
Dim dataStr As String, isChange As Boolean
pReg.Global = True: pReg.Pattern = charQuote: pReg.MultiLine = True
Set pRange = onSheet.Range(onSheet.Cells(firstRow, inCol), onSheet.Cells(lastRow, inCol))
vData = pRange.Value: isChange = False
ReDim vCount(LBound(vData) To UBound(vData), 1 To 1)
For i = LBound(vData) To UBound(vData)
If Application.WorksheetFunction.IsText(vData(i, 1)) Then
dataStr = CStr(vData(i, 1))
Set pResult = pReg.Execute(dataStr)
vCount(i, 1) = pResult.Count
If (pResult.Count Mod 2) > 0 Then
vData(i, 1) = dataStr & charQuote
isChange = True
End If
End If
Next i
If isChange Then
pRange.Value = vData
onSheet.Range(onSheet.Cells(firstRow, outCol), onSheet.Cells(lastRow, outCol)).Value = vCount
Else
MsgBox "Анализируемые данные не содержат непарных кавычек или их нет", vbOKOnly + vbInformation, "Сообщение"
End If
End Sub
Тормозит из-за "прямой" работы с ячейками, попробуйте так
[more]
Код:
'Подключить Microsoft VBScript Regular Expressions 5.5
'onSheet рабочий лист, на котором расположенны данные
'inCol номер столбца на рабочем листе с анализируемыми ячейками
'outCol номер столбца, куда выводиться число кавычек в анализуруемых ячейках
'fristRow номер первой строки с данными на рабочем листе
'lastRow номер последней строки с данными на рабочем листе
Public Sub AddQuotes(ByVal onSheet As Excel.Worksheet, ByVal inCol As Long, _
ByVal outCol As Long, ByVal firstRow As Long, ByVal lastRow As Long)
Const charQuote As String = """"
Dim pReg As New VBScript_RegExp_55.RegExp
Dim pResult As VBScript_RegExp_55.MatchCollection
Dim vData As Variant, pRange As Excel.Range
Dim vCount() As Long, i As Long
Dim dataStr As String, isChange As Boolean
pReg.Global = True: pReg.Pattern = charQuote: pReg.MultiLine = True
Set pRange = onSheet.Range(onSheet.Cells(firstRow, inCol), onSheet.Cells(lastRow, inCol))
vData = pRange.Value: isChange = False
ReDim vCount(LBound(vData) To UBound(vData), 1 To 1)
For i = LBound(vData) To UBound(vData)
If Application.WorksheetFunction.IsText(vData(i, 1)) Then
dataStr = CStr(vData(i, 1))
Set pResult = pReg.Execute(dataStr)
vCount(i, 1) = pResult.Count
If (pResult.Count Mod 2) > 0 Then
vData(i, 1) = dataStr & charQuote
isChange = True
End If
End If
Next i
If isChange Then
pRange.Value = vData
onSheet.Range(onSheet.Cells(firstRow, outCol), onSheet.Cells(lastRow, outCol)).Value = vCount
Else
MsgBox "Анализируемые данные не содержат непарных кавычек или их нет", vbOKOnly + vbInformation, "Сообщение"
End If
End Sub
Lilu1
Ваш макрос можно существенно рационализировать. Посмотрите пример. Обратите внимание на время выполнения.
Код: Sub Main()
Dim i As Long, s As String, x As Range: Application.ScreenUpdating = False
Set x = Range([B10], Cells(Rows.Count, 2).End(xlUp)): a = x.Value
For i = 1 To UBound(a, 1)
s = Replace(a(i, 1), Chr(34), "")
If (Len(a(i, 1)) - Len(s)) Mod 2 <> 0 Then a(i, 1) = a(i, 1) & Chr(34)
Next: x.Value = a
End Sub
Ваш макрос можно существенно рационализировать. Посмотрите пример. Обратите внимание на время выполнения.
Код: Sub Main()
Dim i As Long, s As String, x As Range: Application.ScreenUpdating = False
Set x = Range([B10], Cells(Rows.Count, 2).End(xlUp)): a = x.Value
For i = 1 To UBound(a, 1)
s = Replace(a(i, 1), Chr(34), "")
If (Len(a(i, 1)) - Len(s)) Mod 2 <> 0 Then a(i, 1) = a(i, 1) & Chr(34)
Next: x.Value = a
End Sub
SAS888
Давно замечаю ваш талант в VBA на этом да и на других форумах. В связи с этим не будет ли наглостью попросить вас глянуть уже готовый и работающий макрос на предмет его рационализации? При согласии макрос вышлю в ПМ.
Давно замечаю ваш талант в VBA на этом да и на других форумах. В связи с этим не будет ли наглостью попросить вас глянуть уже готовый и работающий макрос на предмет его рационализации?
При согласии макрос вышлю в ПМ.JekG Ответ см. в личных сообщениях.
Доброго времени суток всем!
Шапку прочитал, и понимаю, что подобного рода вопросы здесь не приветствуются, но все же спрошу, поскольку данная задача для меня разовая, и изучать VBA для ее решения не имею ни возможности ни времени (все равно, что изучит суахили ради одного часа пролетом в Африке, не целесообразно, мне кажется)
Суть следующая, имеется [more=макрос]Sub Save_Comment_As_Picture()
Dim rRange As Range, oComment As Comment, sFile
Dim bVisible As Boolean
sFile = Application.GetSaveAsFilename
If sFile = "False" Then Exit Sub Else sFile = Left(sFile, InStr(1, sFile, "."))
Set rRange = ActiveCell
On Error Resume Next: Set oComment = rRange.Comment
If oComment Is Nothing Then Exit Sub
bVisible = rRange.Comment.Visible
Application.ScreenUpdating = False
With rRange
.Comment.Visible = True
.Comment.Shape.CopyPicture xlScreen, xlBitmap
.Comment.Visible = bVisible
End With
Workbooks.Add
ActiveWorkbook.SaveAs Filename:= _
ThisWorkbook.Path & Application.PathSeparator & "TempBook.xls"
ActiveSheet.Paste
With ActiveSheet.ChartObjects.Add(0, 0, Selection.Width, Selection.Height).Chart
.Paste
.Export Filename:=sFile & "jpg", FilterName:="JPG"
End With
Application.DisplayAlerts = False
ActiveWorkbook.ChangeFileAccess xlReadOnly
Kill ActiveWorkbook.FullName
ActiveWorkbook.Close False
Application.DisplayAlerts = True
Application.ScreenUpdating = True
Set rRange = Nothing: Set oComment = Nothing
End Sub[/more], цель которого извлечь картинку из примечания к ячейке и сохранить ее в jpg файл, с чем он и справляется прекрасно в Exel 2003, и наотрез отказывается в Exel 2007, не могли бы уважаемые специалисты данного топика помочь адаптировать его под Exel 2007, буду премного благодарен.
Шапку прочитал, и понимаю, что подобного рода вопросы здесь не приветствуются, но все же спрошу, поскольку данная задача для меня разовая, и изучать VBA для ее решения не имею ни возможности ни времени (все равно, что изучит суахили ради одного часа пролетом в Африке, не целесообразно, мне кажется)
Суть следующая, имеется [more=макрос]Sub Save_Comment_As_Picture()
Dim rRange As Range, oComment As Comment, sFile
Dim bVisible As Boolean
sFile = Application.GetSaveAsFilename
If sFile = "False" Then Exit Sub Else sFile = Left(sFile, InStr(1, sFile, "."))
Set rRange = ActiveCell
On Error Resume Next: Set oComment = rRange.Comment
If oComment Is Nothing Then Exit Sub
bVisible = rRange.Comment.Visible
Application.ScreenUpdating = False
With rRange
.Comment.Visible = True
.Comment.Shape.CopyPicture xlScreen, xlBitmap
.Comment.Visible = bVisible
End With
Workbooks.Add
ActiveWorkbook.SaveAs Filename:= _
ThisWorkbook.Path & Application.PathSeparator & "TempBook.xls"
ActiveSheet.Paste
With ActiveSheet.ChartObjects.Add(0, 0, Selection.Width, Selection.Height).Chart
.Paste
.Export Filename:=sFile & "jpg", FilterName:="JPG"
End With
Application.DisplayAlerts = False
ActiveWorkbook.ChangeFileAccess xlReadOnly
Kill ActiveWorkbook.FullName
ActiveWorkbook.Close False
Application.DisplayAlerts = True
Application.ScreenUpdating = True
Set rRange = Nothing: Set oComment = Nothing
End Sub[/more], цель которого извлечь картинку из примечания к ячейке и сохранить ее в jpg файл, с чем он и справляется прекрасно в Exel 2003, и наотрез отказывается в Exel 2007, не могли бы уважаемые специалисты данного топика помочь адаптировать его под Exel 2007, буду премного благодарен.
rikamid
Почему-то мне кажется, что собака зарыта в настройках уровня безопасности, который просто режет макросы по умолчанию.
Почему-то мне кажется, что собака зарыта в настройках уровня безопасности, который просто режет макросы по умолчанию.
JekG
Ну эту собаку я отрыл самостоятельно Визуально макрос выполняется абсолютно идентично 2003 Exel-ю, но вот файл результата на положенном ему месте не появляется! Файл делаю в формате .xlsm.
Ну эту собаку я отрыл самостоятельно
Визуально макрос выполняется абсолютно идентично 2003 Exel-ю, но вот файл результата на положенном ему месте не появляется! Файл делаю в формате .xlsm.Добрый вечер!
Помогите с проблемой. Скачиваю базу сайта по недвижимости www.otido.com.ua посредствам vba, текст вместо:
1 кімн. в 2-кімн. кв., ''гостинка'', ПЗР, вул. 30-річчя Перемоги, 9/9/Ц, 28.1/19/с/в і кухня на 2 сім'ї, жилий стан, балкон, с/в розд., 16000у.о., терміново. ПП ''ЗОРЯ НЕРУХОМІСТЬ'' 329636, (093)6258987, (063)4638684
обретает вид:
<B>1 ???-???, ''???,</B> ?? ?. 30-?? ??? 9/9/? 28.1/19/?? ???2 ??, ???, ??, ??., 16000?, ????? ''?? ???̲??' <B>329636, (093)6258987, (063)4638684</B><
Правда у меня вместо вопросов квадратики везде такие ?̲
Что делать?
Помогите с проблемой. Скачиваю базу сайта по недвижимости www.otido.com.ua посредствам vba, текст вместо:
1 кімн. в 2-кімн. кв., ''гостинка'', ПЗР, вул. 30-річчя Перемоги, 9/9/Ц, 28.1/19/с/в і кухня на 2 сім'ї, жилий стан, балкон, с/в розд., 16000у.о., терміново. ПП ''ЗОРЯ НЕРУХОМІСТЬ'' 329636, (093)6258987, (063)4638684
обретает вид:
<B>1 ???-???, ''???,</B> ?? ?. 30-?? ??? 9/9/? 28.1/19/?? ???2 ??, ???, ??, ??., 16000?, ????? ''?? ???̲??' <B>329636, (093)6258987, (063)4638684</B><
Правда у меня вместо вопросов квадратики везде такие ?̲
Что делать?
rikamid
Скорее всего не создавалось изображение, так как была ошибка "нельзя установить размер для заданного типа диаграммы". Поскольку использовалось Resume Next, то процедура выполнялась без вылета по ошибке, но ничего не делая.
Переписал на это вариант, несколько переделав
[more]
Код:
Public Sub Save_Comment_As_Picture()
On Error GoTo errHandle
Dim errChart As Long, vVisible As Boolean
Dim pChart As Excel.ChartObject
Dim sFile As String, isChartError As Boolean
Dim vWidth As Double, vHeight As Double
If Not TypeOf ActiveSheet Is Worksheet Then Exit Sub
If ActiveCell.Comment Is Nothing Then Exit Sub
sFile = ActiveWorkbook.Name & "_" & ActiveSheet.Name & "_" & ActiveCell.Address(False, False, XlReferenceStyle.xlA1)
sFile = Replace(sFile, ".", "_")
sFile = Application.GetSaveAsFilename(sFile, "PNG Format (*.png),*.png,JPG Format (*.jpg),*.jpg", 1)
If (LCase$(sFile) = "false") Or (LCase$(sFile) = "ложь") Then Exit Sub
Application.ScreenUpdating = False: errChart = -2116157060
isChartError = False: vVisible = ActiveCell.Comment.Visible
ActiveCell.Comment.Visible = True
ActiveCell.Comment.Shape.CopyPicture XlPictureAppearance.xlScreen, XlCopyPictureFormat.xlBitmap
'размер растра
ActiveSheet.Paste: vWidth = Selection.Width
vHeight = Selection.Height: Selection.Delete
'диаграмму по размеру растра
Set pChart = ActiveSheet.ChartObjects.Add(10, 10, vWidth, vHeight)
If isChartError Then Set pChart = ActiveSheet.ChartObjects(ActiveSheet.ChartObjects.Count)
pChart.Chart.Paste
pChart.Chart.Export sFile, , False
pChart.Delete
errHandle:
If Err.Number = errChart Then 'возможный вылет с созданной диаграммой
isChartError = True: errChart = -errChart: Err.Clear
Resume Next
ElseIf Err.Number <> 0 Then
MsgBox Err.Description, vbOKOnly + vbInformation, Err.Source
End If
ActiveCell.Comment.Visible = vVisible
Application.ScreenUpdating = True
End Sub
Скорее всего не создавалось изображение, так как была ошибка "нельзя установить размер для заданного типа диаграммы". Поскольку использовалось Resume Next, то процедура выполнялась без вылета по ошибке, но ничего не делая.
Переписал на это вариант, несколько переделав
[more]
Код:
Public Sub Save_Comment_As_Picture()
On Error GoTo errHandle
Dim errChart As Long, vVisible As Boolean
Dim pChart As Excel.ChartObject
Dim sFile As String, isChartError As Boolean
Dim vWidth As Double, vHeight As Double
If Not TypeOf ActiveSheet Is Worksheet Then Exit Sub
If ActiveCell.Comment Is Nothing Then Exit Sub
sFile = ActiveWorkbook.Name & "_" & ActiveSheet.Name & "_" & ActiveCell.Address(False, False, XlReferenceStyle.xlA1)
sFile = Replace(sFile, ".", "_")
sFile = Application.GetSaveAsFilename(sFile, "PNG Format (*.png),*.png,JPG Format (*.jpg),*.jpg", 1)
If (LCase$(sFile) = "false") Or (LCase$(sFile) = "ложь") Then Exit Sub
Application.ScreenUpdating = False: errChart = -2116157060
isChartError = False: vVisible = ActiveCell.Comment.Visible
ActiveCell.Comment.Visible = True
ActiveCell.Comment.Shape.CopyPicture XlPictureAppearance.xlScreen, XlCopyPictureFormat.xlBitmap
'размер растра
ActiveSheet.Paste: vWidth = Selection.Width
vHeight = Selection.Height: Selection.Delete
'диаграмму по размеру растра
Set pChart = ActiveSheet.ChartObjects.Add(10, 10, vWidth, vHeight)
If isChartError Then Set pChart = ActiveSheet.ChartObjects(ActiveSheet.ChartObjects.Count)
pChart.Chart.Paste
pChart.Chart.Export sFile, , False
pChart.Delete
errHandle:
If Err.Number = errChart Then 'возможный вылет с созданной диаграммой
isChartError = True: errChart = -errChart: Err.Clear
Resume Next
ElseIf Err.Number <> 0 Then
MsgBox Err.Description, vbOKOnly + vbInformation, Err.Source
End If
ActiveCell.Comment.Visible = vVisible
Application.ScreenUpdating = True
End Sub
andrewkard1980
Возможно проблема с кодировкой. Смотри какая у тебя и какая там и перекодирую
Возможно проблема с кодировкой. Смотри какая у тебя и какая там и перекодирую
Спасибо огромное!!!!! Оба макроса работают!!! Попробую дописать сама требуемые дальше действия, если не получится обращусь!
Господа есть пробемма, которую срочно надо решить, уже все перепробовал ничего не получается.
Вообщем вот суть.
Есть класс (обертка) для работы с Winsocket из VB(VBA). Так вот этот класс заюзан в Excel, на 2000-2007 все работает, а вот в выходом 2010 версии нехочет. Крошит эксель и все.
Вот собственно класс: CSocketMaster.zip помогите застравить рабоать на Excel 2010. Мне кажется что все дело в не правильном патчинге в нутри саб-классинга. Возможно что-то не архитектура вызовов оконных проуедур изменилась в Excel 2010. Там VBA 7.0 и читал что по внутренностям он отличается от своего предшественника. Темболее в VBA7.0 появились новые типы для поинтеров а также ВБ стал в двух редакциях 32 и 64-ти разрядный. Подскажите куда копать.
Падает после проверки сокета - существует или нет (вызов функции SocketExists из Connect, CSocketMaster.cls line 396)
VBA Выдает следущую ошибку
---------------------------
Microsoft Visual Basic for Applications
---------------------------
Run-time error '-2147417848 (80010108)':
Automation error
The object invoked has disconnected from its clients.
---------------------------
ОК Справка
---------------------------
И эксель Закрывается. подскажите куда копать?
Вообщем вот суть.
Есть класс (обертка) для работы с Winsocket из VB(VBA). Так вот этот класс заюзан в Excel, на 2000-2007 все работает, а вот в выходом 2010 версии нехочет. Крошит эксель и все.
Вот собственно класс: CSocketMaster.zip помогите застравить рабоать на Excel 2010. Мне кажется что все дело в не правильном патчинге в нутри саб-классинга. Возможно что-то не архитектура вызовов оконных проуедур изменилась в Excel 2010. Там VBA 7.0 и читал что по внутренностям он отличается от своего предшественника. Темболее в VBA7.0 появились новые типы для поинтеров а также ВБ стал в двух редакциях 32 и 64-ти разрядный. Подскажите куда копать.
Падает после проверки сокета - существует или нет (вызов функции SocketExists из Connect, CSocketMaster.cls line 396)
VBA Выдает следущую ошибку
---------------------------
Microsoft Visual Basic for Applications
---------------------------
Run-time error '-2147417848 (80010108)':
Automation error
The object invoked has disconnected from its clients.
---------------------------
ОК Справка
---------------------------
И эксель Закрывается. подскажите куда копать?
SIgor33
Мне тоже так кажется, но как узнать какая? могу скинуть файл для анализа. Спасибо!
Добавлено:
Попробывал декодировщиком распознать. Вот http://web.artlebedev.ru/tools/decoder/. Так пишет что декодировал 7-bit ASCII → ISO-8859-5
Правда не докодировал все же
Кракозябры выдает.
Мне тоже так кажется, но как узнать какая? могу скинуть файл для анализа. Спасибо!
Добавлено:
Попробывал декодировщиком распознать. Вот http://web.artlebedev.ru/tools/decoder/. Так пишет что декодировал 7-bit ASCII → ISO-8859-5
Правда не докодировал все же
Кракозябры выдает.
andrewkard1980
Цитата:
какие именно средства vba?
Цитата:
Скачиваю базу сайта по недвижимости www.otido.com.ua посредствам vba
какие именно средства vba?
andrewkard1980
Цитата:
скинь посмотрю может что и получиться
Цитата:
могу скинуть файл для анализа
скинь посмотрю может что и получиться
smirnvlad
Вот это:
sURI = "www.otido.com.ua"
On Error Resume Next
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
' GoTo my1
oHttp.Open "GET", sURI, False
oHttp.Send
htmlcode = oHttp.responseText
Ну и дальше, вытаскиваем html код в котором на сайте когда смотришь, все в норме, а в Excel кракозябры.
Вот это:
sURI = "www.otido.com.ua"
On Error Resume Next
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
' GoTo my1
oHttp.Open "GET", sURI, False
oHttp.Send
htmlcode = oHttp.responseText
Ну и дальше, вытаскиваем html код в котором на сайте когда смотришь, все в норме, а в Excel кракозябры.
andrewkard1980
htmlcode = StrConv(oHttp.responseBody, vbUnicode)
htmlcode = StrConv(oHttp.responseBody, vbUnicode)
Страницы: 123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127
Предыдущая тема: VS 2010
Форум Ru-Board.club — поднят 15-09-2016 числа. Цель - сохранить наследие старого Ru-Board, истории становления российского интернета. Сделано для людей.