请老师帮忙修改代码

abc123281

天真无鞋 发表于 2024-8-4 10:13
老师非常正确就是速度有点慢。

地址查找.rar (1.58 MB, 下载次数: 2)

2024-8-4 10:28 上传

点击文件名下载附件

天真无鞋

abc123281 发表于 2024-8-4 10:28

谢谢老师

sxbjzjf110

天真无鞋 发表于 2024-8-4 10:13
老师非常正确就是速度有点慢。

复制粘贴速度肯定慢，要快就要用数组。

sxbjzjf110

这是用数组写的，速度非常快，你试一下。

天真无鞋

sxbjzjf110 发表于 2024-8-4 11:42
这是用数组写的，速度非常快，你试一下。

老师太棒了，能否在加一句，在执行查找前先删除“测试”工作表的所有数据，从第4行业开到最后，在查询过程中隐藏打开工作簿，

gwjkkkkk

Option Explicit
Sub test()
    Dim ar, br, i&, j&, r&, strFileName$, strPath$, strFind$
   
    If [C3].Value = Empty Then Exit Sub Else strFind = [C3].Value
   
    Application.ScreenUpdating = False
   
    With Worksheets(2)
        .[A3].CurrentRegion.Offset(1).Clear
        ar = .[A3].CurrentRegion.Value
        ReDim ar(1 To 10 ^ 4, 1 To UBound(ar, 2)) As String
        
        strPath = Left(ThisWorkbook.Path, InStrRev(ThisWorkbook.Path, "\")) & "数据库\Test\"
        strFileName = Dir(strPath & "*.xls")
        Do Until strFileName = ""
            If strFileName <> ThisWorkbook.Name Then
                With GetObject(strPath & strFileName)
                    br = .Worksheets(1).[A1].CurrentRegion.Value
                    For i = 1 To UBound(br)
                        If br(i, 6) = strFind Then
                            r = r + 1
                            For j = 1 To UBound(br, 2)
                                ar(r, j) = br(i, j)
                            Next j
                        End If
                    Next i
                    .Close False
                End With
            End If
            strFileName = Dir
        Loop
        If r Then
            .[A4].Resize(r, UBound(ar, 2)) = ar
            .Activate
        End If
    End With

    Application.ScreenUpdating = True
    Beep
End Sub

gwjkkkkk

参与一下。。。

sxbjzjf110

你再试试。。。。

天真无鞋

sxbjzjf110 发表于 2024-8-4 13:25
你再试试。。。。

谢谢老师，关闭刷新是可以了，但是每次执行的时候没有清除第一次粘贴的数据，需求是每次执行的时候，把上次粘贴的数据全部清除，在从清单工作表第4行开始粘贴。

天真无鞋

gwjkkkkk 发表于 2024-8-4 12:19
参与一下。。。

谢谢老师的参与