本守则隐藏除德国之外的所有国旗。 我有一个存储国家短名称的变量,如GER,NL等。
是否有办法只显示相应的标志而不为每种情况创建多个这样的长真/假块?
'Show proper flag on list and charts
Worksheets("Recommendations").Shapes("GermanyRecommendations").Visible = True
Worksheets("Recommendations").Shapes("NetherlandsRecommendations").Visible = False
Worksheets("Recommendations").Shapes("AustriaRecommendations").Visible = False
Worksheets("Recommendations").Shapes("CzechRecommendations").Visible = False
Worksheets("Recommendations").Shapes("FranceRecommendations").Visible = False
Worksheets("Recommendations").Shapes("PolandRecommendations").Visible = False
Worksheets("Recommendations").Shapes("SlovakiaRecommendations").Visible = False
Worksheets("Recommendations").Shapes("RomaniaRecommendations").Visible = False
Worksheets("Recommendations").Shapes("SpainRecommendations").Visible = False
Worksheets("Recommendations").Shapes("BelgiumRecommendations").Visible = False
Worksheets("Recommendations").Shapes("HungaryRecommendations").Visible = False
答案 0 :(得分:7)
比@ Moosli的解决方案简洁一点:
Sub SetFlagVisibility(strCountry As String)
Dim shp As Shape
For Each shp In Worksheets("Recommendations").Shapes
shp.Visible = (shp.Name = strCountry)
Next
End Sub
答案 1 :(得分:2)
你可以循环所有形状并设置所有 Shapes Visible = false ,之后只需将你要看到的形状设置为 True
Sub main ()
Call setShapeVisible("GermanyRecommendations")
End Sub
Sub setShapeVisible(byVal strCountry as String)
Dim shp As Shape
For Each shp In Worksheets("Recommendations").Shapes
shp.Visible = False
Next
Worksheets("Recommendations").Shapes(strCountry).Visible = True
End Sub
答案 2 :(得分:0)
将附件图像放置在与工作表相同的文件夹中。 (很抱歉,并非所有标志都在那里)。将其命名为flags.png。 在要显示标志的单元格中输入两个字母国家代码。 选择单元格并调用此宏:
Sub addflag()
Static flags, filepath As String
If flags = vbNullString Then
flags = ":af:al:dz:ad:ao:ag:ar:am:au:at:az:bs:bh:bd:bb" & _
":by:be:bz:bj:bt:bo:ba:bw:br:bn:bg:bf:mm:bi:kh" & _
":cm:ca:cv:cf:td:cl:cn:co:km:cd:cg:cr:ci:hr:cu" & _
":cy:cz:dk:dj:dm:do:tl:ec:eg:sv:gq:er:ee:et:fj" & _
":fi:fr:ga:gm:ge:de:gh:gr:gd:gt:gn:gw:gy:ht:hn" & _
":hu:ic:in:id:ir:iq:ie:il:it:jm:jp:jo:kz:ke:ki" & _
":xk:kp:kr:kw:kg:la:lv:lb:ls:lr:ly:li:lt:lu:mk" & _
":mg:mw:my:mv:ml:mt:mh:mr:mu:mx:fm:md:mc:mn:me" & _
":ma:mz:na:nr:np:nl:nz:ni:ne:ng:no:om:pk:pw:pa" & _
":pg:py:pe:ph:pl:pt:qa:ro:ru:rw:kn:lc:vc:ws:sm" & _
":st:sa:sn:rs:sc:sl:sg:sk:si:sb:so:za:es:lk:ps" & _
":sr:sz:se:ch:sy:tw:tj:tz:th:tg:to:tt:tn:tr:tm" & _
":tv:ug:ua:ae:gb:us:uy:uz:vu:va:ve:vn:ye:zm:zw"
filepath = Application.ActiveWorkbook.Path & "\flags.png"
End If
Const nr = 13
Const nc = 15
Dim cll As range
Dim sh As Shape
Dim ss As String
Dim xr, xc, pos, r, c As Long
Dim vv As Variant
Dim offr, offc As Long
offr = nr \ 2
offc = nc \ 2
For Each cll In Selection.Cells
vv = cll.Value
If Application.WorksheetFunction.IsText(vv) Then
ss = CStr(vv)
If Len(ss) = 2 Then
pos = CLng(InStr(1, flags, ss, vbTextCompare))
If pos <> 0 Then
pos = (pos - 2) \ 3
r = offr - (pos \ nc)
c = offc - (pos Mod nc)
Debug.Print ss, pos, r, c
With cll
Dim w, h
w = .Width
h = .Height
Set sh = ActiveSheet.Shapes.AddPicture(filepath, msoFalse, msoTrue, .Left, .Top, w, h)
With sh
.Top = cll.Top
.Left = cll.Left
.Height = h
.Width = w
.Placement = xlMoveAndSize
With .PictureFormat.Crop
.PictureWidth = nc * w
.PictureHeight = nr * h
.PictureOffsetX = c * w
.PictureOffsetY = r * h
End With
End With
End With
End If
End If
End If
Next
End Sub