Здравствуйте переименовал кнопки в Digit0 .. Digit9, удалил код, привязанный к кнопкам в модуле класса ClDigitalButtons [vba]
Код
Private WithEvents cb As CommandButton Private cell As Range Public Sub Init(ctrl As CommandButton, r As Range) Set cb = ctrl Set cell = r End Sub Private Sub Class_Terminate() Set cb = Nothing Set cell = Nothing End Sub Private Sub cb_Click() cell = cell.Value & cb.Caption End Sub
[/vba]в стандартном модуле [vba]
Код
Dim colButtons As Collection Sub hookButtons(ws As Object) Dim dBtn As ClDigitalButtons Dim obj As OLEObject Set colButtons = New Collection For Each obj In ws.OLEObjects If TypeOf obj.Object Is CommandButton And Left(obj.Name, 5) = "Digit" Then Set dBtn = New ClDigitalButtons dBtn.Init obj.Object, ws.[B1] colButtons.Add dBtn End If Next End Sub
[/vba]в модуле ЭтаКнига[vba]
Код
Private Sub Workbook_Open() hookButtons ActiveSheet End Sub Private Sub Workbook_SheetActivate(ByVal Sh As Object) hookButtons Sh End Sub
[/vba]
Здравствуйте переименовал кнопки в Digit0 .. Digit9, удалил код, привязанный к кнопкам в модуле класса ClDigitalButtons [vba]
Код
Private WithEvents cb As CommandButton Private cell As Range Public Sub Init(ctrl As CommandButton, r As Range) Set cb = ctrl Set cell = r End Sub Private Sub Class_Terminate() Set cb = Nothing Set cell = Nothing End Sub Private Sub cb_Click() cell = cell.Value & cb.Caption End Sub
[/vba]в стандартном модуле [vba]
Код
Dim colButtons As Collection Sub hookButtons(ws As Object) Dim dBtn As ClDigitalButtons Dim obj As OLEObject Set colButtons = New Collection For Each obj In ws.OLEObjects If TypeOf obj.Object Is CommandButton And Left(obj.Name, 5) = "Digit" Then Set dBtn = New ClDigitalButtons dBtn.Init obj.Object, ws.[B1] colButtons.Add dBtn End If Next End Sub
[/vba]в модуле ЭтаКнига[vba]
Код
Private Sub Workbook_Open() hookButtons ActiveSheet End Sub Private Sub Workbook_SheetActivate(ByVal Sh As Object) hookButtons Sh End Sub
duckky, все дело в версии MSXML парсера, у вас нету 4.0, вот и выдает ошибку [vba]
Код
Private ver% Function МЕТЦБР2#(Optional Code% = 2, Optional dDate As Date) Dim d As Object, ddate1 As Date, elem As Object: Set d = CreateObject("msxml2.domdocument." & MSXMLVersion & ".0") dDate = IIf(dDate, dDate, Date): ddate1 = Application.EDate(dDate, -1): d.async = 0 d.Load ("https://www.cbr.ru/scripts/xml_metall.asp?date_req1=" & ddate1 & "&date_req2=" & dDate) Select Case ver Case Is > 3 'Установлен MSXML >= 4.0, используем XPath функцию last() МЕТЦБР2 = CDbl(d.SelectSingleNode("*/Record[@Code='" & Code & "'][last()]/Buy").Text) Case Else 'иначе используем IXMLDOMNodeList Set elem = d.SelectNodes("*/Record[@Code='" & Code & "']/Buy") МЕТЦБР2 = CDbl(elem(elem.Length - 1).Text) End Select Set d = Nothing End Function Private Function MSXMLVersion%() Dim arrVersions() If ver > 0 Then MSXMLVersion = ver: Exit Function With GetObject("winmgmts:{impersonationLevel=impersonate}!\\.\root\default:StdRegProv") .EnumValues 2 ^ 31, "CLSID\{2933BF90-7B36-11D2-B20E-00C04F983E60}\VersionList\", arrVersions End With 'номер старшей версии MSXML, установленной в системе MSXMLVersion = Split(arrVersions(0), ".")(0) ver = MSXMLVersion End Function
[/vba]
duckky, все дело в версии MSXML парсера, у вас нету 4.0, вот и выдает ошибку [vba]
Код
Private ver% Function МЕТЦБР2#(Optional Code% = 2, Optional dDate As Date) Dim d As Object, ddate1 As Date, elem As Object: Set d = CreateObject("msxml2.domdocument." & MSXMLVersion & ".0") dDate = IIf(dDate, dDate, Date): ddate1 = Application.EDate(dDate, -1): d.async = 0 d.Load ("https://www.cbr.ru/scripts/xml_metall.asp?date_req1=" & ddate1 & "&date_req2=" & dDate) Select Case ver Case Is > 3 'Установлен MSXML >= 4.0, используем XPath функцию last() МЕТЦБР2 = CDbl(d.SelectSingleNode("*/Record[@Code='" & Code & "'][last()]/Buy").Text) Case Else 'иначе используем IXMLDOMNodeList Set elem = d.SelectNodes("*/Record[@Code='" & Code & "']/Buy") МЕТЦБР2 = CDbl(elem(elem.Length - 1).Text) End Select Set d = Nothing End Function Private Function MSXMLVersion%() Dim arrVersions() If ver > 0 Then MSXMLVersion = ver: Exit Function With GetObject("winmgmts:{impersonationLevel=impersonate}!\\.\root\default:StdRegProv") .EnumValues 2 ^ 31, "CLSID\{2933BF90-7B36-11D2-B20E-00C04F983E60}\VersionList\", arrVersions End With 'номер старшей версии MSXML, установленной в системе MSXMLVersion = Split(arrVersions(0), ".")(0) ver = MSXMLVersion End Function
Видимо собака зарылась в разнице версий Excel, у меня сейчас под рукой только 2007 именно поэтому тут написано
Цитата
Старайтесь прилагать файлы в версии Excel 2003-го офиса(xls), так как эти файлы могут открыть пользователи с любой версией Excel, в отличие от файлов версий Excel 2007/2010/2013 (xlsх).
При открытии в E3 проверки данных нет, скрин делать лень. Нашел диапазон на скрытом листе, в 2007 не поддерживаются источники для проверки данных с другого листа напрямую исправил макрос во 2 посте
второй вариант макроса[vba]
Код
Private Sub Worksheet_Change(ByVal Target As Range) Dim s$, x$, v As Variant If Not Intersect(Target, Range("E3")) Is Nothing Then s = Target.Validation.Formula1 v = Evaluate(s) If Left(s, 1) = "=" Then If TypeName(v) = "Range" Then v = v.Formula x = Join(Application.Transpose(v), ";") Else: x = s End If Application.Run "Лист1.Макрос_" & UBound(Split(";" & Mid(x, 1, InStr(1, x, Target) - 1), ";")) End If End Sub
[/vba]
Видимо собака зарылась в разнице версий Excel, у меня сейчас под рукой только 2007 именно поэтому тут написано
Цитата
Старайтесь прилагать файлы в версии Excel 2003-го офиса(xls), так как эти файлы могут открыть пользователи с любой версией Excel, в отличие от файлов версий Excel 2007/2010/2013 (xlsх).
При открытии в E3 проверки данных нет, скрин делать лень. Нашел диапазон на скрытом листе, в 2007 не поддерживаются источники для проверки данных с другого листа напрямую исправил макрос во 2 посте
второй вариант макроса[vba]
Код
Private Sub Worksheet_Change(ByVal Target As Range) Dim s$, x$, v As Variant If Not Intersect(Target, Range("E3")) Is Nothing Then s = Target.Validation.Formula1 v = Evaluate(s) If Left(s, 1) = "=" Then If TypeName(v) = "Range" Then v = v.Formula x = Join(Application.Transpose(v), ";") Else: x = s End If Application.Run "Лист1.Макрос_" & UBound(Split(";" & Mid(x, 1, InStr(1, x, Target) - 1), ";")) End If End Sub
вместо -9 написать -99 и, соответственно, вместо G4:G99 указать диапазон, охватывающий все данные и формулу лучше переписать так, ибо, если будут дробные числа будет работать неверно
вместо -9 написать -99 и, соответственно, вместо G4:G99 указать диапазон, охватывающий все данные и формулу лучше переписать так, ибо, если будут дробные числа будет работать неверно