再次求助麻烦老师帮忙重写代码

天真无鞋 · 发表于 2024-8-4 10:57

再次求助麻烦老师帮忙重写代码，详见附加文件，谢谢！

蓝桥玄霜 · 发表于 2024-8-4 13:57

查询的例子：

jaxxcyh · 发表于 2024-8-4 14:04

Sub CopyData()
Dim fd As FileDialog
Dim folderPath As String
Set fd = Application.FileDialog(msoFileDialogFolderPicker)
fd.Title = "请选择数据文件夹"
fd.InitialFileName = ThisWorkbook.Path
'显示选择文件夹对话框
If fd.Show = -1 Then
folderPath = fd.SelectedItems(1)
Else
MsgBox "未选择数据文件夹，程序退出"
Set fd = Nothing
Exit Sub
End If
'获取数据文件
Dim fileName As String
fileName = Dir(folderPath & "\*.xls*")
Dim wsList As Worksheet, wsTest As Worksheet
Dim targetWorkbook As Workbook
Dim targetSheet As Worksheet
Dim lastRow As Long
Dim lastCol As Long
Dim i As Long, j As Long
Dim matchFound As Boolean
Set wsList = ThisWorkbook.Worksheets("清单")
Dim targetValue As Variant
targetValue = ThisWorkbook.Sheets("数据录入").Range("C3").Value
ScreenUpdating = False
Dim myArr(), myCopyArr(), myCopyArrTrns()
ReDim myCopyArr(1 To 1000, 1 To 100) '根据数据量大小预设一下数组的大小
Dim n As Long '匹配目标计数器
n = 0
Do While fileName <> ""
Set targetWorkbook = Workbooks.Open(folderPath & "" & fileName)
Set targetSheet = targetWorkbook.Worksheets("测试")
myArr = targetSheet.UsedRange
lastRow = UBound(myArr, 1)
lastCol = UBound(myArr, 2)
For i = 2 To lastRow
If myArr(i, 6) = targetValue Then
n = n + 1 '找到一条匹配的记录，计数器加1
If n > UBound(myCopyArr, 1) Then '如果记录数组容量不够用就扩容
myCopyArrTrns = Application.Transpose(myCopyArr) '由于扩容只能扩展数组最后一维，无法直接扩展第一维，所以进入数组转置
ReDim Preserve myCopyArrTrns(LBound(myCopyArr, 1) To UBound(myCopyArr, 2), LBound(myCopyArr, 1) To UBound(myCopyArr, 1) * 2) '现有容量翻倍
myCopyArr = Application.Transpose(myCopyArrTrns)
End If
For j = 1 To lastCol
myCopyArr(n, j) = myArr(i, j) '复制匹配的数据
Next
End If
Next i
targetWorkbook.Close SaveChanges:=False
Set targetSheet = Nothing
Set targetWorkbook = Nothing
MsgBox "扫描完一个文件，开始扫描下一个文件" & "目前已有" & n & "条记录"
fileName = Dir()
Loop
MsgBox "扫描完毕，共找到" & n & "条匹配的数据"
wsList.Range("a4").Resize(n, lastCol).Value = myCopyArr
ScreenUpdating = True
End Sub

复制代码

jaxxcyh · 发表于 2024-8-4 14:23

jaxxcyh 发表于 2024-8-4 14:04

do循环之前加一句： wsList.UsedRange.Offset(3).ClearContents
end sub前加一句： if n>0 then wslist.Activate

Qs18 · 发表于 2024-8-4 15:13

Sub qs()
Dim fso As Object
Dim folderPath As String
Dim file As Object
Dim wb As Workbook, xb As Workbook
Set wb = ThisWorkbook
tt = Sheet3.Range("c3").Value
ph = ThisWorkbook.Path
x = VBA.InStrRev(ph, "\")
ph = Mid(ph, 1, 29) & "数据库\Test"
' 创建FileSystemObject对象
Application.ScreenUpdating = False
Set fso = CreateObject("Scripting.FileSystemObject")
' 设置要遍历的文件夹路径
folderPath = ph
' 检查文件夹是否存在
If fso.FolderExists(folderPath) Then
      ' 获取文件夹
      Set folder = fso.GetFolder(folderPath)
      ' 遍历文件夹中的所有文件
      For Each file In folder.Files
         ' 检查文件是否是Excel文件
         If LCase(fso.GetExtensionName(file.Name)) = "xlsx" Or _
            LCase(fso.GetExtensionName(file.Name)) = "xls" Then
            ' 这里是文件名
'             Debug.Print file.Name
            Set xb = Workbooks.Open(ph & "\" & file.Name, 0)
            arr = xb.Sheets("测试").Range("a2").CurrentRegion.Value
            xb.Close (0)
            m = 0
            ReDim brr(1 To UBound(arr), 1 To UBound(arr, 2))
                  For i = 1 To UBound(arr)
                     If arr(i, 6) <> "" And arr(i, 6) = tt Then
                        m = m + 1
                        For j = 1 To UBound(arr, 2)
                              brr(m, j) = arr(i, j)
                        Next

                     End If
                  Next

            ' 这里可以添加你的代码来处理每个Excel文件
         End If
         rw = wb.Sheets("清单").Cells(Rows.Count, 1).End(3).Row + 1
         wb.Sheets("清单").Range("a" & rw).Resize(m, UBound(arr, 2)) = brr
      Next file
Else
      MsgBox "指定的文件夹不存在。"
End If
' 清理
Set fso = Nothing: Set wb = Nothing
Set folder = Nothing: Set xb = Nothing
Application.ScreenUpdating = True
End Sub

Qs18 · 发表于 2024-8-4 15:14

试试.............

Qs18 · 发表于 2024-8-4 15:18

试试........

天真无鞋 · 发表于 2024-8-4 15:25

Qs18 发表于 2024-8-4 15:18
试试........

老师指定文件夹不存在

Qs18 · 发表于 2024-8-4 15:34

天真无鞋发表于 2024-8-4 15:25
老师指定文件夹不存在

我这里代码运行正常的.............

天真无鞋 · 发表于 2024-8-4 15:42

Qs18 发表于 2024-8-4 15:34
我这里代码运行正常的.............

我一步一步测试，直接跳到没有找到指定文件夹，文件夹都在。

Sub qs()
Dim fso As Object
Dim folderPath As String
Dim file As Object
Dim wb As Workbook, xb As Workbook
Set wb = ThisWorkbook
tt = Sheet3.Range("c3").Value
ph = ThisWorkbook.Path
x = VBA.InStrRev(ph, "\")
ph = Mid(ph, 1, 29) & "数据库\Test"
' 创建FileSystemObject对象
Application.ScreenUpdating = False
Set fso = CreateObject("Scripting.FileSystemObject")
' 设置要遍历的文件夹路径
folderPath = ph
' 检查文件夹是否存在
If fso.FolderExists(folderPath) Then
      ' 获取文件夹
      Set folder = fso.GetFolder(folderPath)
      ' 遍历文件夹中的所有文件
      For Each file In folder.Files
         ' 检查文件是否是Excel文件
         If LCase(fso.GetExtensionName(file.Name)) = "xlsx" Or _
            LCase(fso.GetExtensionName(file.Name)) = "xls" Then
            ' 这里是文件名
'             Debug.Print file.Name
            Set xb = Workbooks.Open(ph & "\" & file.Name, 0)
            arr = xb.Sheets("测试").Range("a2").CurrentRegion.Value
            xb.Close (0)
            m = 0
            ReDim brr(1 To UBound(arr), 1 To UBound(arr, 2))
                  For i = 1 To UBound(arr)
                     If arr(i, 6) <> "" And arr(i, 6) = tt Then
                        m = m + 1
                        For j = 1 To UBound(arr, 2)
                              brr(m, j) = arr(i, j)
                        Next

                     End If
                  Next

            ' 这里可以添加你的代码来处理每个Excel文件
         End If
         rw = wb.Sheets("清单").Cells(Rows.Count, 1).End(3).Row + 1
         wb.Sheets("清单").Range("a" & rw).Resize(m, UBound(arr, 2)) = brr
      Next file
Else
      MsgBox "指定的文件夹不存在。"
End If
' 清理
Set fso = Nothing: Set wb = Nothing
Set folder = Nothing: Set xb = Nothing
Application.ScreenUpdating = True
End Sub

		自动登录	找回密码
密码			免费注册

[求助] 再次求助麻烦老师帮忙重写代码