將形狀從上一個工作表移動到當前工作表

Question

我有20個人字形形狀的分組，用於標識您到電子表格的距離。 用戶從選項卡1開始，第一個人字形為彩色，然后繼續。 在選項卡15上，為15個V形燕尾形上色，在選項卡20上，所有20個V形燕尾形上色。

我曾嘗試標識以前的活動工作表，但是卻不斷出錯。 用戶可以從選項卡1跳到5到10，或者從選項卡20跳到5到13。結果，我不能使用.previous命令。 我嘗試使用全局變量代替停用工作表來獲取lastWS名稱，因為我認為這是最好的方法，但無濟於事。 IE瀏覽器，這是我的全局變量

Public lastWS As Worksheet

要更改人字形顏色，效果很好，我在工作表激活時打電話給我

Private Sub Worksheet_Activate()
  Call chevronColours(1)
End Sub

在每個工作表上，我都有這個來識別上次使用的工作表：

Private Sub Worksheet_DeActivate()
  Set lastWS = ActiveSheet
End Sub

我的模塊代碼是：

Sub chevronColours(k As Integer)

Dim r As Integer, g As Integer, b As Integer, i As Integer
Set wbk = ThisWorkbook
Set currentWS = ActiveSheet
lastWS.Shapes("Group 2").Cut
wbk.ActiveSheet.Range("B2").Select
wbk.ActiveSheet.Paste

For i = 1 To 19
  If i <= k Then
    currentWS.Shapes("Chevron " & i).Fill.ForeColor.RGB = RGB(0, 255, 0)
  Else
    currentWS.Shapes("Chevron " & i).Fill.ForeColor.RGB = RGB(255, 255, 255)
  End If
Next i

End Sub

在這種情況下，它表明找不到具有指定名稱的項目。 使用調試器，我發現這是因為使用取消激活過程時，我的lastWS成為當前工作表。

我該怎么做才能以這種方式使用上一個工作表？

Answer 1

而不是Set lastWS = ActiveSheet而是使用Set lastWS = Me 。

另外，我猜您在所有工作表中都有Activate和Deactivate事件嗎？

您可以使用ThisWorkbook模塊中的單個Workbook_SheetActivate和Workbook_SheetDeactivate實例來完成此操作

Private Sub Workbook_SheetDeactivate(ByVal Sh As Object)
    Set lastWS = Sh
End Sub

另外，您的chevronColours Sub可以像這樣通過工作簿

Private Sub Workbook_SheetActivate(ByVal Sh As Object)
    chevronColours Sh
End Sub

並定義為

Sub chevronColours(currentWS As Worksheet)

我想您會發現chevronColours代碼還有其他一些問題。 這是重構的代碼

Sub chevronColours(currentWS As Worksheet)
    Dim k As Long, i As Long
    Dim rng As Range
    Dim shp As Shape
    Dim g As GroupObject

    Application.ScreenUpdating = False
    Set rng = Selection
    lastWS.Shapes("Group 2").Cut
    currentWS.Paste
    Set g = Selection
    rng.Select
    g.Name = "Group 2"
    With currentWS.Range("B2")
        g.Top = .Top
        g.Left = .Left
    End With
    k = currentWS.Index
    If g.ShapeRange.GroupItems.Count = currentWS.Parent.Worksheets.Count Then
        For i = 1 To g.ShapeRange.GroupItems.Count
            g.ShapeRange.GroupItems(i).Fill.ForeColor.RGB = IIf(i <= k, vbGreen, vbWhite)
        Next i
    Else
        ' Sheets vs chevron count mismatch
        '  what now?
    End If
    Application.ScreenUpdating = True
End Sub

Answer 2

存儲對工作表的引用

我所做的是使用Static ChevronList As Object引用ArrayList。 工作表名稱將添加到ArrayList。 ArrayList.IndexOf_3(Worksheet.Name)返回工作表名稱的從零開始的索引。

更好的解決方案-靜態變量

變量確實有生命周期。 指示在兩次調用之間保留局部變量。 可以將靜態變量視為具有內存的局部變量。 靜態變量是一個局部變量，其生存期是整個模塊的生存期，而不是聲明它的過程。 實際上，只要代碼模塊處於活動狀態，靜態變量就會保留其值。 不必一直運行任何代碼。 因此，靜態變量具有局部變量的范圍，但具有模塊級變量的生存期。

處理形狀

您應該給該組取一個有意義的名稱。

  ActiveSheet.Shapes("Group 2").Name = "Chevron Group" 

將名稱數組傳遞給Shapes.Range()屬性將返回數組中所有形狀的ShapeRange 。 使用ShapeRange修改一組形狀的屬性比單獨更改它們更有效。

工作簿活動

正如Chris Neilsen提到的那樣，請使用Workbook_SheetActivate而不是各個工作表的Worksheet_Activate事件。 我建議還建議從Workbook_Open事件中調用該子例程。 用戶啟用內容后，將觸發Workbook_Open 。 如果用戶打開工作簿，更改工作表，然后啟用內容

 Private Sub Workbook_Open() MoveChevronGroup ActiveSheet.Range("B2") End Sub 

---

我沒有費心使用上一個工作表來跟蹤組的位置。 在該組中搜索20張紙實際上是瞬時的，可以防止可能的錯誤。

---

Option Explicit
Const DebugMode = True

Private Sub Workbook_Open()
    MoveChevronGroup ActiveSheet.Range("B2")
End Sub

Private Sub Workbook_SheetActivate(ByVal sh As Object)
    Application.ScreenUpdating = False
    MoveChevronGroup sh.Range("B2")
    Application.ScreenUpdating = True
End Sub

Private Sub MoveChevronGroup(Optional Destination As Range)
    Const GroupName As String = "Chevron Group"
    Static ChevronList As Object
    Dim ChevronGroup As Shape, ws As Worksheet
    Dim results() As Variant
    Dim ChevronCount As Long, n As Long
    If ChevronList Is Nothing Then Set ChevronList = CreateObject("System.Collections.ArrayList")

    For Each ws In ThisWorkbook.Worksheets
        On Error Resume Next
        Set ChevronGroup = ws.Shapes(GroupName)
        On Error GoTo 0
        If Not ChevronGroup Is Nothing Then Exit For
    Next

    Set ws = Destination.Parent

    If Not ChevronGroup.Parent.Name = ws.Name Then
        ChevronGroup.Cut
        Destination.Parent.Paste
        Set ChevronGroup = ws.Shapes(GroupName)
        ChevronGroup.Left = Destination.Left
        ChevronGroup.Top = Destination.Top
    End If

    If Not ChevronList.Contains(ws.Name) Then ChevronList.Add ws.Name
    ChevronCount = ChevronList.IndexOf_3(ws.Name) + 1

    If DebugMode Then Debug.Print "ChevronList.Count: "; ChevronList.Count, "ChevronList.IndexOf_3(ws.Name) + 1: "; ChevronList.IndexOf_3(ws.Name) + 1

    ReDim results(ChevronCount - 1)
    For n = 1 To ChevronCount
        results(n - 1) = n
    Next

    If DebugMode Then Debug.Print "Results Array Values: "; Join(results, ",")

    ChevronGroup.Fill.ForeColor.RGB = RGB(255, 255, 255)
    ChevronGroup.GroupItems.Range(results).Fill.ForeColor.RGB = RGB(0, 255, 0)
End Sub

修改后的代碼以將Shape Index而不是Shape Name添加到results（）中。 使用形狀名稱似乎存在錯誤。 我要問這個錯誤。 由於更改，需要將雪佛龍按順序添加到組中。

下載Chevrons Demo.xlsm 。 主要代碼在工作簿的代碼模塊中。 准備工作簿，添加工作表和人PrepWorkbook的代碼在PrepWorkbook模塊中。