如何将切片器移动到不同的工作片 [英] How to Move Slicer to Different Workskeet

问题描述

我正在使用Excel 2010。

我想将切片器移动到另一个工作表并使用关注VBA代码。 

ActiveSheet.Shapes（" Responsible"）。剪切

工作表（ "Lookups"）。范围（"A22"）。PasteSpecial

其中"责任"是切片机的名称。

部分有效。 它从活动工作表中剪切切片器，并将其粘贴到工作表"Lookups"，但作为图片，而不是切片器。

知道我做错了什么吗？ / p>

提前谢谢，

Jane

解决方案

您必须直接粘贴到工作表中（使用工作表对象），PasteSpecial不起作用。请参阅下面的代码，需要对Microsoft Forms库的引用。

Andreas。

 Function CopyShape（ByVal S As Shape，ByVal R As Range，_ 
可选ByVal StartSnap为fmSnapPoint = -1，可选ByVal EndSnap为fmSnapPoint = -1，_ 
可选ByVal Move As Boolean = True，_ 
可选ByVal调整大小作为变体）作为形状
'复制或移动形状S并将其调整到范围R 
'如果R有区域然后是
'，则形状是从R $的第一个区域构建到最后一个区域b $ b'如果是IsMissing（调整大小）然后Resize = True 
'else 
'如果IsMissing（调整大小）然后Resize = R.Cells.Count>，则构造形状以适合R 
' ; 1 
 Dim c作为评论
 Dim Left As Single，Top as Single，Width as Single，Height as Single，X as Single，Y as Single 
 Dim SnapPoint as fmSnapPoint 
 Dim区域范围
选择案例S.Type 
案例msoComment 
'搜索评论对象
每个c在S.Parent.Comments 
如果c.Shape.Name = S.Name然后
'复制单元格
 c.Parent.Copy 
'仅将注释粘贴到目标单元格
 R.PasteSpecial xlPasteComments，xlPasteSpecialOperationNone 
 Application.CutCopyMode = False 
'删除旧评论
如果Move Then c.Delete 
 Set CopyShape = R.Comment.Shape 
退出函数
结束如果
下一个
 Case Else 
如果IsMissing（调整大小）则_ 
如果R.Areas.Count> 1然后Resize = True Else Resize = R.Count> 1 
'到另一张表？ 
 If（S.Parent.Parent.Name<> R.Parent.Parent.Name）或（S.Parent.Name<> R.Parent.Name）或不移动然后
如果Move Then S.Cut Else S.Copy 
 R.Parent.Paste 
 Application.CutCopyMode = False 
 If Val（Application.Version）< 12然后
'获取最后一个形状
 Set S = R.Parent.Shapes（R.Parent.Shapes.Count）
 Else 
'搜索第一个非评论形状结束
 Dim i As Long 
使用R.Parent 
 For i = .Shapes.Count To 1 Step -1 
 Set S = .Shapes（i）
如果S.Type<> msoComment然后退出
下一个
结束
结束如果
结束如果
'计算头寸
如果R.Areas.Count = 1那么
如果StartSnap< 0然后
设定面积= R（1,1）
否则
设定面积= R 
结束如果
否则
设定面积= R.Areas（ 1）
结束如果
如果StartSnap< 0然后_ 
如果R.Areas.Count = 1则StartSnap = fmSnapPointTopLeft Else StartSnap = fmSnapPointCenter 
 SnapPoint = StartSnap 
 GoSub CalculatePos 
 Left = X 
 Top = Y 
如果调整大小则
如果R.Areas.Count = 1那么
如果是EndSnap< 0然后
设置区域= R.Cells（R.Cells.Count）
 Else 
设置区域= R 
结束如果
否则
设置面积= R.Areas（R.Areas.Count）
结束如果
如果EndSnap< 0然后_ 
如果R.Areas.Count = 1则EndSnap = fmSnapPointBottomRight Else EndSnap = fmSnapPointCenter 
 SnapPoint = EndSnap 
 GoSub CalculatePos 
宽度= X  - 左
高度= Y  - 顶部
结束如果
'移动它
 S.Left =左
 S.Top =顶部
如果调整大小则
 S.Width =宽度
 S.Height =高度
如果S.LockAspectRatio那么
'我们现在可能超出范围
如果S.Width>宽度然后
 S.Width =宽度
'位于垂直中心
 S.Top = S.Top +（高度 -  S.Height）/ 2 
否则
 '位于水平中心
 S.Left = S.Left +（宽度 - 宽度）/ 2 
结束如果
结束如果
结束如果
设置CopyShape = S 
结束选择
退出函数
 
 CalculatePos：
选择案例SnapPoint 
案例fmSnapPointBottomCenter 
 X = Area.Left + Area.Width / 2 
 Y = Area.Top + Area.Height 
 Case fmSnapPointBottomLeft 
 X = Area.Left 
 Y = Area.Top + Area.Height 
 Case fmSnapPointBottomRight 
 X = Area.Left + Area.Width 
 Y = Area.Top + Area.Height 
 Case fmSnapPointCenter 
 X = Area.Left + Area.Width / 2 
 Y = Area.Top + Area.Height / 2 
案例fmSnapPointCenterLeft 
 X = Area.Left 
 Y = Area.Top + Area.Height / 2 
案例fmSnapPointCenterRight 
 X = Area.Left + Area.Width 
 Y = Area.Top + Area.Height / 2 
案例fmSnapPointTopCenter 
 X = Area.Left + Area.Width / 2 
 Y = Area.Top 
 Case fmSnapPointTopLeft 
 X = Area.Left 
 Y = Area.Top 
 Case fmSnapPointTopRight 
 X = Area.Left + Area.Width 
 Y = Area.Top 
结束选择
返回
结束函数
 

Hi,

I am using Excel 2010.

I want to move a slicer to a different worksheet and am using the following VBA code. 

ActiveSheet.Shapes("Responsible").Cut

Worksheets("Lookups").Range("A22").PasteSpecial

Where "Responsible" is the name of the slicer.

It partially works.  It cuts the slicer from the Active worksheet, and pastes it to the worksheet "Lookups", but as a picture, not as a slicer.

Any idea what I am doing wrong?

Thank you in advance,

Jane

解决方案

You must paste into the sheet directly (using the sheet object), PasteSpecial did not work. See code below, needs a reference to Microsoft Forms library.

Andreas.

Function CopyShape(ByVal S As Shape, ByVal R As Range, _
    Optional ByVal StartSnap As fmSnapPoint = -1, Optional ByVal EndSnap As fmSnapPoint = -1, _
    Optional ByVal Move As Boolean = True, _
    Optional ByVal Resize As Variant) As Shape
  'Copy or move and resize the shape S to range R
  '  If R has areas then
  '     the shape is build from first area to last area in R
  '     if IsMissing(Resize) then Resize = True
  '  else
  '     the shape is build to fit R
  '     if IsMissing(Resize) then Resize = R.Cells.Count > 1
  Dim c As Comment
  Dim Left As Single, Top As Single, Width As Single, Height As Single, X As Single, Y As Single
  Dim SnapPoint As fmSnapPoint
  Dim Area As Range
  Select Case S.Type
    Case msoComment
      'Search the comment object
      For Each c In S.Parent.Comments
        If c.Shape.Name = S.Name Then
          'Copy the cell
          c.Parent.Copy
          'Paste the comment only to the destination cell(s)
          R.PasteSpecial xlPasteComments, xlPasteSpecialOperationNone
          Application.CutCopyMode = False
          'Delete old comment
          If Move Then c.Delete
          Set CopyShape = R.Comment.Shape
          Exit Function
        End If
      Next
    Case Else
      If IsMissing(Resize) Then _
        If R.Areas.Count > 1 Then Resize = True Else Resize = R.Count > 1
      'To a different sheet?
      If (S.Parent.Parent.Name <> R.Parent.Parent.Name) Or (S.Parent.Name <> R.Parent.Name) Or Not Move Then
        If Move Then S.Cut Else S.Copy
        R.Parent.Paste
        Application.CutCopyMode = False
        If Val(Application.Version) < 12 Then
          'Get the last shape
          Set S = R.Parent.Shapes(R.Parent.Shapes.Count)
        Else
          'Search the first non-comment shape from the end
          Dim i As Long
          With R.Parent
            For i = .Shapes.Count To 1 Step -1
              Set S = .Shapes(i)
              If S.Type <> msoComment Then Exit For
            Next
          End With
        End If
      End If
      'Calculate positions
      If R.Areas.Count = 1 Then
        If StartSnap < 0 Then
          Set Area = R(1, 1)
        Else
          Set Area = R
        End If
      Else
        Set Area = R.Areas(1)
      End If
      If StartSnap < 0 Then _
        If R.Areas.Count = 1 Then StartSnap = fmSnapPointTopLeft Else StartSnap = fmSnapPointCenter
      SnapPoint = StartSnap
      GoSub CalculatePos
      Left = X
      Top = Y
      If Resize Then
        If R.Areas.Count = 1 Then
          If EndSnap < 0 Then
            Set Area = R.Cells(R.Cells.Count)
          Else
            Set Area = R
          End If
        Else
          Set Area = R.Areas(R.Areas.Count)
        End If
        If EndSnap < 0 Then _
          If R.Areas.Count = 1 Then EndSnap = fmSnapPointBottomRight Else EndSnap = fmSnapPointCenter
        SnapPoint = EndSnap
        GoSub CalculatePos
        Width = X - Left
        Height = Y - Top
      End If
      'Move it
      S.Left = Left
      S.Top = Top
      If Resize Then
        S.Width = Width
        S.Height = Height
        If S.LockAspectRatio Then
          'We may exceeds the range now
          If S.Width > Width Then
            S.Width = Width
            'Place in vertical center
            S.Top = S.Top + (Height - S.Height) / 2
          Else
            'Place in horizontal center
            S.Left = S.Left + (Width - S.Width) / 2
          End If
        End If
      End If
      Set CopyShape = S
  End Select
  Exit Function

CalculatePos:
  Select Case SnapPoint
    Case fmSnapPointBottomCenter
      X = Area.Left + Area.Width / 2
      Y = Area.Top + Area.Height
    Case fmSnapPointBottomLeft
      X = Area.Left
      Y = Area.Top + Area.Height
    Case fmSnapPointBottomRight
      X = Area.Left + Area.Width
      Y = Area.Top + Area.Height
    Case fmSnapPointCenter
      X = Area.Left + Area.Width / 2
      Y = Area.Top + Area.Height / 2
    Case fmSnapPointCenterLeft
      X = Area.Left
      Y = Area.Top + Area.Height / 2
    Case fmSnapPointCenterRight
      X = Area.Left + Area.Width
      Y = Area.Top + Area.Height / 2
    Case fmSnapPointTopCenter
      X = Area.Left + Area.Width / 2
      Y = Area.Top
    Case fmSnapPointTopLeft
      X = Area.Left
      Y = Area.Top
    Case fmSnapPointTopRight
      X = Area.Left + Area.Width
      Y = Area.Top
  End Select
  Return
End Function

这篇关于如何将切片器移动到不同的工作片的文章就介绍到这了，希望我们推荐的答案对大家有所帮助，也希望大家多多支持IT屋！