[已解决]如何让筛选的图片，在原来位置？

Thomas2800

eZ7h22jF.rar (670.3 KB, 下载次数: 40)

2009-9-14 10:02 上传

点击文件名下载附件
如何让筛选的图片，在原来位置？
如题，如何才能实现附件里的要求，谢谢

最佳答案

月排行榜 / 总排行榜

amulee

2009-9-14 10:07

Sub ad()
    Dim pth As String
    Dim pthname As String
    Dim rng1 As Range
    Dim rng2 As Range
            On Error Resume Next
            pth = ThisWorkbook.Path & "\" & "New Folder\"
            Application.ScreenUpdating = False
                        With Sheet1
                          Set rng1 = .Cells(1, 1)
                                If Len(rng1.Text) Then
                                     Set rng2 = .Cells(1, 3)
                                            .Pictures(rng2.Address(0, 0)).Delete
                                            pthname = Dir(pth & rng1.Text & "*")
                                        With ActiveSheet.Pictures.Insert(pth & pthname)
                                                        .Name = rng2.Address(0, 0)
                                                        .Height = rng2.Height
                                                        .Top = rng2.Top
                                                        .Left = rng2.Left
                                                        .Width = rng2.Width
                                        End With
                                End If
                        End With
            Application.ScreenUpdating = True
           
End Sub

[此贴子已经被作者于2009-9-14 10:08:03编辑过]

跳转到最佳答案楼层

amulee

Sub ad()
    Dim pth As String
    Dim pthname As String
    Dim rng1 As Range
    Dim rng2 As Range
            On Error Resume Next
            pth = ThisWorkbook.Path & "\" & "New Folder\"
            Application.ScreenUpdating = False
                        With Sheet1
                          Set rng1 = .Cells(1, 1)
                                If Len(rng1.Text) Then
                                     Set rng2 = .Cells(1, 3)
                                            .Pictures(rng2.Address(0, 0)).Delete
                                            pthname = Dir(pth & rng1.Text & "*")
                                        With ActiveSheet.Pictures.Insert(pth & pthname)
                                                        .Name = rng2.Address(0, 0)
                                                        .Height = rng2.Height
                                                        .Top = rng2.Top
                                                        .Left = rng2.Left
                                                        .Width = rng2.Width
                                        End With
                                End If
                        End With
            Application.ScreenUpdating = True
           
End Sub

[此贴子已经被作者于2009-9-14 10:08:03编辑过]

Thomas2800

谢谢，我想复杂了，呵呵 

Thomas2800

不要按按钮就能实现变化，如何实现呢？ 谢谢

amulee

以下代码放到Sheet1中

Private Sub Worksheet_Change(ByVal Target As Range)
    If Target.Count > 1 Then Exit Sub
    If Target.Address = "$A$1" Then
        Dim pth As String
        Dim pthname As String
        Dim rng1 As Range
        Dim rng2 As Range
                On Error Resume Next
                pth = ThisWorkbook.Path & "\" & "New Folder\"
                Application.ScreenUpdating = False
                            With Sheet1
                              Set rng1 = .Cells(1, 1)
                                    If Len(rng1.Text) Then
                                         Set rng2 = .Cells(1, 3)
                                                .Pictures(rng2.Address(0, 0)).Delete
                                                pthname = Dir(pth & rng1.Text & "*")
                                            With ActiveSheet.Pictures.Insert(pth & pthname)
                                                            .Name = rng2.Address(0, 0)
                                                            .Height = rng2.Height
                                                            .Top = rng2.Top
                                                            .Left = rng2.Left
                                                            .Width = rng2.Width
                                            End With
                                    End If
                            End With
                Application.ScreenUpdating = True

    End If
End Sub