Он должен делать видимыми или невидимыми фигуры со словом в названии "плюс" или "минус". Но не работает - выдает ошибку 400. Как его изменить, чтобы он скрывал-отображал эти шейпы на листе ? [vba]
Код
Sub МакросВидимостиВклВыкл() Dim i As Long For i = 1 To ActiveSheet.Shapes.Count If i = 1 Then ActiveSheet.Shapes.Range(Array("плюс " & i)).Visible = False Else ActiveSheet.Shapes.Range(Array("плюс " & i)).Visible = _ ActiveSheet.Shapes.Range(Array("плюс " & i)).Visible End If Next i
For i = 1 To ActiveSheet.Shapes.Count If i = 1 Then ActiveSheet.Shapes.Range(Array("минус " & i)).Visible = False Else ActiveSheet.Shapes.Range(Array("минус " & i)).Visible = _ ActiveSheet.Shapes.Range(Array("минус " & i)).Visible End If Next i
End Sub
[/vba]
Здравствуйте. Подскажите как поправить макрос.
Он должен делать видимыми или невидимыми фигуры со словом в названии "плюс" или "минус". Но не работает - выдает ошибку 400. Как его изменить, чтобы он скрывал-отображал эти шейпы на листе ? [vba]
Код
Sub МакросВидимостиВклВыкл() Dim i As Long For i = 1 To ActiveSheet.Shapes.Count If i = 1 Then ActiveSheet.Shapes.Range(Array("плюс " & i)).Visible = False Else ActiveSheet.Shapes.Range(Array("плюс " & i)).Visible = _ ActiveSheet.Shapes.Range(Array("плюс " & i)).Visible End If Next i
For i = 1 To ActiveSheet.Shapes.Count If i = 1 Then ActiveSheet.Shapes.Range(Array("минус " & i)).Visible = False Else ActiveSheet.Shapes.Range(Array("минус " & i)).Visible = _ ActiveSheet.Shapes.Range(Array("минус " & i)).Visible End If Next i
Sub Макрос() Dim i As Integer, myShape As Shape, m As Boolean Set sd = CreateObject("Scripting.Dictionary") i = 0 For Each myShape In ActiveSheet.Shapes If InStr(myShape.Name, "Плюс") > 0 Or InStr(myShape.Name, "Минус") > 0 Then If Not sd.Exists(myShape.Name) Then i = i + 1: sd.Add i, myShape.Name Next m = IIf(ActiveSheet.Shapes(sd(1)).Visible, False, True) ActiveSheet.Shapes.Range(sd.Items).Visible = m End Sub
[/vba]
Пробуйте [vba]
Код
Sub Макрос() Dim i As Integer, myShape As Shape, m As Boolean Set sd = CreateObject("Scripting.Dictionary") i = 0 For Each myShape In ActiveSheet.Shapes If InStr(myShape.Name, "Плюс") > 0 Or InStr(myShape.Name, "Минус") > 0 Then If Not sd.Exists(myShape.Name) Then i = i + 1: sd.Add i, myShape.Name Next m = IIf(ActiveSheet.Shapes(sd(1)).Visible, False, True) ActiveSheet.Shapes.Range(sd.Items).Visible = m End Sub
Sub Макрос() Dim i As Integer, myShape As Shape, m As Boolean, sd As Object Set sd = CreateObject("Scripting.Dictionary") i = 0 For Each myShape In ActiveSheet.Shapes If InStr(myShape.Name, "Плюс") > 0 Or InStr(myShape.Name, "Минус") > 0 Then If Not sd.Exists(myShape.Name) Then i = i + 1: sd.Add i, myShape.Name Next m = ActiveSheet.Shapes(sd(1)).Visible ActiveSheet.Shapes.Range(sd.Items).Visible = Not m End Sub
[/vba]
Попробуйте так [vba]
Код
Sub Макрос() Dim i As Integer, myShape As Shape, m As Boolean, sd As Object Set sd = CreateObject("Scripting.Dictionary") i = 0 For Each myShape In ActiveSheet.Shapes If InStr(myShape.Name, "Плюс") > 0 Or InStr(myShape.Name, "Минус") > 0 Then If Not sd.Exists(myShape.Name) Then i = i + 1: sd.Add i, myShape.Name Next m = ActiveSheet.Shapes(sd(1)).Visible ActiveSheet.Shapes.Range(sd.Items).Visible = Not m End Sub
А так можно чередовать, плюс видимый, минус не видимый и наоборот [vba]
Код
Sub Макрос() Dim i As Integer, j As Integer, myShape As Shape, m As Boolean, sd As Object Set sd = CreateObject("Scripting.Dictionary") Set sd("Плюс") = CreateObject("Scripting.Dictionary") Set sd("Минус") = CreateObject("Scripting.Dictionary") i = 0: j = 0 For Each myShape In ActiveSheet.Shapes If InStr(myShape.Name, "Плюс") > 0 Then If Not sd("Плюс").Exists(myShape.Name) Then i = i + 1: sd("Плюс").Add i, myShape.Name If InStr(myShape.Name, "Минус") > 0 Then If Not sd("Минус").Exists(myShape.Name) Then j = j + 1: sd("Минус").Add j, myShape.Name Next m = ActiveSheet.Shapes(sd("Плюс")(1)).Visible ActiveSheet.Shapes.Range(sd("Плюс").Items).Visible = Not m ActiveSheet.Shapes.Range(sd("Минус").Items).Visible = m End Sub
[/vba]
А так можно чередовать, плюс видимый, минус не видимый и наоборот [vba]
Код
Sub Макрос() Dim i As Integer, j As Integer, myShape As Shape, m As Boolean, sd As Object Set sd = CreateObject("Scripting.Dictionary") Set sd("Плюс") = CreateObject("Scripting.Dictionary") Set sd("Минус") = CreateObject("Scripting.Dictionary") i = 0: j = 0 For Each myShape In ActiveSheet.Shapes If InStr(myShape.Name, "Плюс") > 0 Then If Not sd("Плюс").Exists(myShape.Name) Then i = i + 1: sd("Плюс").Add i, myShape.Name If InStr(myShape.Name, "Минус") > 0 Then If Not sd("Минус").Exists(myShape.Name) Then j = j + 1: sd("Минус").Add j, myShape.Name Next m = ActiveSheet.Shapes(sd("Плюс")(1)).Visible ActiveSheet.Shapes.Range(sd("Плюс").Items).Visible = Not m ActiveSheet.Shapes.Range(sd("Минус").Items).Visible = m End Sub
Sub Макрос() Dim i As Integer, j As Integer, myShape As Shape, m As Boolean, sd As Object Set sd = CreateObject("Scripting.Dictionary") Set sd("Плюс") = CreateObject("Scripting.Dictionary") Set sd("Минус") = CreateObject("Scripting.Dictionary") i = 0: j = 0 For Each myShape In ActiveSheet.Shapes If InStr(1, myShape.Name, "Плюс", 1) > 0 Then If Not sd("Плюс").Exists(myShape.Name) Then i = i + 1: sd("Плюс").Add i, myShape.Name If InStr(1, myShape.Name, "Минус", 1) > 0 Then If Not sd("Минус").Exists(myShape.Name) Then j = j + 1: sd("Минус").Add j, myShape.Name Next If sd("Плюс").Count = 0 Then MsgBox "На листе отсутствуют фигуры в имени которых содержится ""Плюс""": Exit Sub If sd("Минус").Count = 0 Then MsgBox "На листе отсутствуют фигуры в имени которых содержится ""Минус""": Exit Sub m = ActiveSheet.Shapes(sd("Плюс")(1)).Visible ActiveSheet.Shapes.Range(sd("Плюс").Items).Visible = Not m ActiveSheet.Shapes.Range(sd("Минус").Items).Visible = m End Sub
[/vba]
Попробуйте так [vba]
Код
Sub Макрос() Dim i As Integer, j As Integer, myShape As Shape, m As Boolean, sd As Object Set sd = CreateObject("Scripting.Dictionary") Set sd("Плюс") = CreateObject("Scripting.Dictionary") Set sd("Минус") = CreateObject("Scripting.Dictionary") i = 0: j = 0 For Each myShape In ActiveSheet.Shapes If InStr(1, myShape.Name, "Плюс", 1) > 0 Then If Not sd("Плюс").Exists(myShape.Name) Then i = i + 1: sd("Плюс").Add i, myShape.Name If InStr(1, myShape.Name, "Минус", 1) > 0 Then If Not sd("Минус").Exists(myShape.Name) Then j = j + 1: sd("Минус").Add j, myShape.Name Next If sd("Плюс").Count = 0 Then MsgBox "На листе отсутствуют фигуры в имени которых содержится ""Плюс""": Exit Sub If sd("Минус").Count = 0 Then MsgBox "На листе отсутствуют фигуры в имени которых содержится ""Минус""": Exit Sub m = ActiveSheet.Shapes(sd("Плюс")(1)).Visible ActiveSheet.Shapes.Range(sd("Плюс").Items).Visible = Not m ActiveSheet.Shapes.Range(sd("Минус").Items).Visible = m End Sub
А вы проверьте, существуют фигуры в имени которых присутствует слово "Плюс". А лучше создайте фигуру с именем в котором будет содержаться слово "Плюс", например "Плюс 1111". Сейчас скачал мой же файл и у меня всё отрабатывает корректно.
А вы проверьте, существуют фигуры в имени которых присутствует слово "Плюс". А лучше создайте фигуру с именем в котором будет содержаться слово "Плюс", например "Плюс 1111". Сейчас скачал мой же файл и у меня всё отрабатывает корректно.msi2102
Попробуйте так Sub Макрос() Dim i As Integer, myShape As Shape, m As Boolean, sd As Object Set sd = CreateObject("Scripting.Dictionary") i = 0 For Each myShape In ActiveSheet.Shapes If InStr(myShape.Name, "Плюс") > 0 Or InStr(myShape.Name, "Минус") > 0 Then If Not sd.Exists(myShape.Name) Then i = i + 1: sd.Add i, myShape.Name Next m = ActiveSheet.Shapes(sd(1)).Visible ActiveSheet.Shapes.Range(sd.Items).Visible = Not m End Sub
К сообщению приложен файл: 0548029.xlsb (18.7 Kb)
Вот этот вроде работает. Подскажите как при появлении шейпов (включении у них свойства Visible) - поставить у них появление свойства "на передний план" (ZOrder msoBringToFront) ?
Попробуйте так Sub Макрос() Dim i As Integer, myShape As Shape, m As Boolean, sd As Object Set sd = CreateObject("Scripting.Dictionary") i = 0 For Each myShape In ActiveSheet.Shapes If InStr(myShape.Name, "Плюс") > 0 Or InStr(myShape.Name, "Минус") > 0 Then If Not sd.Exists(myShape.Name) Then i = i + 1: sd.Add i, myShape.Name Next m = ActiveSheet.Shapes(sd(1)).Visible ActiveSheet.Shapes.Range(sd.Items).Visible = Not m End Sub
К сообщению приложен файл: 0548029.xlsb (18.7 Kb)
Вот этот вроде работает. Подскажите как при появлении шейпов (включении у них свойства Visible) - поставить у них появление свойства "на передний план" (ZOrder msoBringToFront) ?bazanski
Сообщение отредактировал bazanski - Понедельник, 27.11.2023, 14:11