以下为vba写的程序，能实现筛选模式下，可见部分复制，并可粘贴到可见区域。可见复制部分转为vb编译后引用能复制，但粘贴转为vb编译后引用就无反映了。

Dim cn As Integer, r() As String, rc As Integer, cc As Integer '可见复制
Sub kejianqy()
  Dim a, b, c, d, fsrow, fscol, lsrow, lscol, rws, Cls, i, j As Long
  On Error Resume Next
  Application.ScreenUpdating = False
  rc = 0
  cc = 0
  a = 0 '行计数器
  b = 0 '列计数器
  Selection.SpecialCells(xlCellTypeVisible).Select
  Selection.Copy
  cn = Selection.Areas.Count
  fsrow = Selection.Areas(1).Range("a1").Row
  fscol = Selection.Areas(1).Range("a1").Column
  lsrow = Selection.Areas(cn).Range("a1").Row
  lscol = Selection.Areas(cn).Range("a1").Column
  rws = Selection.Areas(cn).Rows.Count
  Cls = Selection.Areas(cn).Columns.Count
  c = fsrow '起始行
  d = fscol '起始列
  For i = fsrow To (lsrow + rws - 1)
    If Rows(i).Hidden = False Then
      rc = rc + 1
    End If
  Next
  For j = fscol To (lscol + Cls - 1)
    If Columns(j).Hidden = False Then
      cc = cc + 1
    End If
  Next
  ReDim r(rc - 1, cc - 1)
  While (a <= rc - 1)
    If Rows(c).Hidden = False Then
      d = fscol
      b = 0
      While (b <= cc - 1)
        If Columns(d).Hidden = False Then
          r(a, b) = Cells(c, d)
          b = b + 1
        End If
        d = d + 1
      Wend
      a = a + 1
    End If
    c = c + 1
  Wend
  Application.ScreenUpdating = True
End Sub
Sub kejianzt()
  Dim k, l, m, n As Long
  On Error Resume Next
  Application.ScreenUpdating = False
  m = Selection.Row
  k = 1
  While (k <= rc)
    If Rows(m).Hidden = False Then
      n = Selection.Column
      l = 1
      While (l <= cc)
        If Columns(n).Hidden = False Then
          Cells(m, n).Value = r(k - 1, l - 1)
          l = l + 1
        End If
        n = n + 1
      Wend
      k = k + 1
    End If
    m = m + 1
  Wend
  Application.ScreenUpdating = True
End Sub