提取工作薄数据到一个汇总表中

yizhiduxiuaa

要求：想将各分表里的第9行汇总到这个表中。也就是说当第一列的某一行，例如6行1列为”1“时候，1和工作薄1的名称相同，此时提取工作薄1中的第9行数据到这个表格的第6行中

另外，我自己写了个程序不知道哪里错了，也请大佬们帮忙指点下

NadrsSaber

Private Sub drCmd_Click()

    Dim col As Long
    col = Sheets("全月").Range("E2").End(xlToRight).Column
   
    Dim rqRange As Range
    Dim rqStr As String
    For Each rqRange In Sheets("全月").Range(Cells(2, 5), Cells(2, col))
        rqStr = Month(rqRange) & "." & Day(rqRange)
        If Sheets("全月").Cells(3, rqRange.Column) = "" Then
            Call drData(rqStr, rqRange.Column)
        End If
    Next

End Sub

Public Function drData(str As String, num As Long)

    Dim FileStr As String
    FileStr = ThisWorkbook.Path & "\MCD CRM Daily Market New Member Report-" & str & ".xlsx"
   
    Dim s As String
    s = Dir(FileStr)
    If s = "" Then Exit Function
   
    Application.ScreenUpdating = False
   
    Dim wb As Workbook
    Dim ws As Worksheet
   
    Set wb = Workbooks.Open(FileStr)
    Set ws = wb.Sheets("新增会员数据")
   
    Dim r1 As Range
    Dim r2 As Range
    Dim row1 As Long
    Dim row2 As Long
   
    row1 = ThisWorkbook.Sheets("全月").Range("B2").End(xlDown).Row
    row2 = ws.Range("E50000").End(xlUp).Row
   
    For Each r1 In ThisWorkbook.Sheets("全月").Range("B3:B" & row1)
   
        Set r2 = ws.Range("E6:E" & row2).Find(r1, , , xlWhole)
        If r2 Is Nothing Then
            ThisWorkbook.Sheets("全月").Cells(r1.Row, num).Value = 0
        Else
            ThisWorkbook.Sheets("全月").Cells(r1.Row, num).Value = r2.Offset(0, 2)
        End If
   
    Next
   
    wb.Close
   
    Application.ScreenUpdating = True
   
    Set wb = Nothing
    Set ws = Nothing
   
End Function

刚帮人做了个类似的, 既然你会写, 可以看着改改......

xiangbaoan

'汇总簿中工作表格式不一样，如 簿2没有 代码 一列
Option Explicit
Sub test()
Dim d As Object, Cn As Object, p$, f$, s$, i%
Set Cn = CreateObject("ADODB.Connection")
If Application.Version < 12 Then
    Cn.Open "Provider=Microsoft.Jet.OLEDB.4.0;Extended Properties='Excel 8.0;HDR=no';Data Source=" & ThisWorkbook.FullName
    s = "Excel 8.0;HDR=no;Database="
Else
    Cn.Open "Provider=Microsoft.ACE.OLEDB.12.0;Extended Properties='Excel 12.0;HDR=no';Data Source=" & ThisWorkbook.FullName
    s = "Excel 12.0;HDR=no;Database="
End If
Set d = CreateObject("Scripting.Dictionary")
p = ThisWorkbook.Path & "\"
f = Dir(p & "*.xls*")
Do While Len(f)
    If f <> ThisWorkbook.Name Then
        If Val(f) Then d(Val(f)) = "SELECT * FROM [" & s & p & f & "].[$c9:f9]"
    End If
    f = Dir
Loop
For i = 6 To [a65536].End(xlUp).Row
    With Cells(i, 1)
        If d.Exists(Val(.Value)) Then .Offset(, 1).CopyFromRecordset Cn.Execute(d(.Value)) Else .Offset(, 1).Resize(, 4) = ""
    End With
Next
Set d = Nothing
Cn.Close
Set Cn = Nothing
MsgBox "ok!", 64
End Sub

yizhiduxiuaa

感谢楼上两位大佬回复和指点，不过我水平菜，感觉看得不是很懂啊，有没有更简洁的代码，用字典直接从其他工作薄提取数据啊？