使用ADO+SQL读取数据文件夹里面的工作簿数据

fzxba

cmo9020 发表于 2023-4-15 20:07
谢谢导师...在请教一下
我发现刚开始修改不成功能原因
就是所有目标工作簿必须都要相同有A6的 ...

不急。。。

mmwwdd

Sub 取值()
Dim MyPath, MyName As String
Dim wb As Workbook
Dim ws As Worksheet
Dim Mfso As Object
Dim Msub As Object
Dim Msub1 As Object
Dim sht As Worksheet
Set sht = Sheets("Sheet1")
wjj = sht.Range("D1").Value
rq = Left(sht.Range("B1").Value, 1)
Set d = CreateObject("scripting.dictionary")
Set Mfso = CreateObject("scripting.filesystemobject")
MyPath = ThisWorkbook.Path & "\數據\"
Set Msub = Mfso.getfolder(MyPath).subfolders
  For Each mm In Msub
  If wjj = Right(mm, Len(mm) - InStrRev(mm, "\")) Then
    Set Msub1 = Mfso.getfolder(mm).subfolders
       For Each nn In Msub1
        If rq = Right(nn, 1) Then
     MyName = Dir(nn & "\*.xls*")
     Do While MyName <> ""
        Set wb = GetObject(nn & "\" & MyName)
         With wb.Sheets("Report")
         r = Cells(Rows.Count, "B").End(3).Row + 1
         arr = .Range("A14:F18")
         arr = Application.Transpose(arr)
         sht.Range("B" & r).Resize(UBound(arr), UBound(arr, 2)) = arr
         sht.Range("A" & r & ":A" & r + UBound(arr) - 1) = .Range("J3")
         
         Erase arr
         End With
        wb.Close False
        MyName = Dir
     Loop
     End If
       Next
  End If
  Next
End Sub

mmwwdd

mmwwdd

用字典可能好一些

mmwwdd

实际就是练手，并不复杂，但觉得你的表格不规范，可能遇到问题

mmwwdd

我觉得，不用SQL了的时候尽量不用，字典+数组解决最好，实际SQL并不是在VBA编程中的首选

cmo9020

mmwwdd 发表于 2023-4-16 07:24
实际就是练手，并不复杂，但觉得你的表格不规范，可能遇到问题

谢谢导师的帮助
我有自己写了一个需要打开工作簿进行复制
但觉的取数据有点慢,代码也有些问题
会变成有多余的数据出現,我在研究研究一下,谢谢您~


Sub ReadD()
    ThisWorkbook.Worksheets("Sheet1").Range("A3:I100").ClearContents
Dim FolderPath As String
Dim Filename As String
Dim wb As Workbook
Dim ws As Worksheet
Dim i As Long
Dim Data As Variant
Dim Year As String
Year = Range("B1").Value
Dim Month As String
Select Case Range("D1").Value
Case "1月"
Month = Year & "01"
Case "2月"
Month = Year & "02"
Case "3月"
Month = Year & "03"
Case "4月"
Month = Year & "04"
End Select
Dim FolderName As String
FolderName = Range("F1").Value
   FolderPath = "D:\数据\" & FolderName  & "\" & Month & "\"

Application.ScreenUpdating = False
Filename = Dir(FolderPath & "*.xlsx")
Do While Filename <> ""
Set wb = Workbooks.Open(FolderPath & Filename, False, True)
Set ws = wb.Worksheets("Report")

    ' 复制 J3
    Data = ws.Range("J3").Value
    i = i + 1
    ThisWorkbook.Worksheets("Sheet1").Range("A" & i + 2).Value = Data
   
    ' 寻找相同项目并复制数据
    Dim j As Long
    For j = 2 To 8
        Dim FindItem As Variant
        FindItem = ThisWorkbook.Worksheets("Sheet1").Cells(2, j).Value
        Dim FoundCell As Range
        Set FoundCell = ws.Range("A:A").Find(FindItem, LookIn:=xlValues)
        If Not FoundCell Is Nothing Then
            ThisWorkbook.Worksheets("Sheet1").Cells(2 + i, j).Value = FoundCell.Offset(0, 1).Value
        End If
    Next j
   
    wb.Close SaveChanges:=False
    Filename = Dir()
Loop
Application.ScreenUpdating = True
End Sub

fzxba

cmo9020 发表于 2023-4-15 20:07
谢谢导师...在请教一下
我发现刚开始修改不成功能原因
就是所有目标工作簿必须都要相同有A6的 ...

按需求改进.rar (135.5 KB, 下载次数: 19)

2023-4-16 20:33 上传

点击文件名下载附件

cmo9020

fzxba 发表于 2023-4-16 20:33

谢谢导师帮忙...
不然用开启工作簿方式......遇到30几个档案
真的超级慢...........
非常感谢您~

cmo9020

cmo9020 发表于 2023-4-17 19:38
谢谢导师帮忙...
不然用开启工作簿方式......遇到30几个档案
真的超级慢...........

Test.rar (143.41 KB, 下载次数: 2)

2023-4-30 11:29 上传

点击文件名下载附件

谢谢导师...不知道您有没有空在请教一下
现在遇到一个问题
如果读取目标工作表 J3单元格有重复
不知道是不是能读取目标D5单元格的日期+D8单元格时间下去做判断
在提取出最新的那一笔数据


例如：
数据\8038-2429999\202303\
里面现在有2个工作簿 Z33288 和Z33288-1 这2笔里面[Report$A14:B]数据不相同
现在需要的是Z33288-1那笔最新数据
如果是以您这目前代码来修改,有没有办法读取判断目标工作表的
D5单元格的日期+D8单元格时间判断最新的那一笔数据

如果您有空闲在希望您能帮忙一下,谢谢您~