提取相应单位元格中的数据

lzjexp

要求通过公式或VBA把1月至2月份的数据提取过来:

就是把每个月中每个部门下的每个人的实际考勤天数提取到汇总表相应的单元格中（有的人会同时在两个部门工作）。

chxw68

1. Sub test()
   
2.   Dim r%, i%
   
3.   Dim arr, brr
   
4.   Dim ws As Worksheet
   
5.   Dim d As Object
   
6.   Set d = CreateObject("scripting.dictionary")
   
7.   For Each ws In Worksheets
   
8.     If ws.Name Like "*月" Then
   
9.       With ws
   
10.         r = .Cells(.Rows.Count, 1).End(xlUp).Row
    
11.         arr = .Range("a2:c" & r)
    
12.         For i = 1 To UBound(arr)
    
13.           If Not d.exists(arr(i, 1)) Then
    
14.             Set d(arr(i, 1)) = CreateObject("scripting.dictionary")
    
15.           End If
    
16.           If Not d(arr(i, 1)).exists(arr(i, 2)) Then
    
17.             ReDim brr(1 To 14)
    
18.             brr(1) = arr(i, 1)
    
19.             brr(2) = arr(i, 2)
    
20.           Else
    
21.             brr = d(arr(i, 1))(arr(i, 2))
    
22.           End If
    
23.           n = Val(ws.Name) + 2
    
24.           brr(n) = brr(n) + arr(i, 3)
    
25.           d(arr(i, 1))(arr(i, 2)) = brr
    
26.         Next
    
27.       End With
    
28.     End If
    
29.   Next
    
30.   With Worksheets("汇总")
    
31.     .UsedRange.Offset(1, 0).Clear
    
32.     m = 1
    
33.     For Each aa In d.keys
    
34.       For Each bb In d(aa).keys
    
35.         m = m + 1
    
36.         .Cells(m, 1).Resize(1, UBound(brr)) = d(aa)(bb)
    
37.       Next
    
38.     Next
    
39.   End With
    
40. End Sub
    

复制代码

chxw68

详见附件。

auloveagbb

论坛关于这个方面的好多例子呢，可以找找

魂断蓝桥

Sub 查询()
Dim cnn As Object, RS, i
Dim Sql As String, sh As Worksheet
For Each sh In Sheets
    If sh.Name Like "*月" Then
        Sql = Sql & "select 部门名称,姓名,考勤天数,""" & sh.Name & """ AS 月份 from [" & sh.Name & "$A1:C] WHERE 姓名 is not null UNION ALL "
    End If
Next
Sql = Left(Sql, Len(Sql) - 11)
Sql = "transform sum(考勤天数) SELECT 部门名称,姓名 FROM (" & Sql & ") GROUP BY 部门名称,姓名 ORDER BY 1,2 pivot 月份 "
Set cnn = CreateObject("ADODB.CONNECTION")
Set RS = CreateObject("adodb.Recordset")
Application.ScreenUpdating = False
cnn.Open "Provider=Microsoft.ACE.OleDb.12.0;Extended Properties='Excel 12.0;HDR=YES'; Data Source=" & ThisWorkbook.FullName
Sheet3.Activate
Cells.Clear
RS.Open Sql, cnn, 1, 1
For i = 0 To RS.Fields.Count - 1
   Cells(1, i + 1) = RS.Fields(i).Name
Next
Range("a2").CopyFromRecordset RS
RS.Close: Set RS = Nothing
cnn.Close: Set cnn = Nothing
Application.ScreenUpdating = True
End Sub

lzjexp

chxw68 发表于 2016-11-10 15:35

这个解决的方案太好了，非常完美，太感谢了。这是第二次帮我解决大问题了。

lzjexp

chxw68 发表于 2016-11-10 15:35

非常感谢您再次对我大力相助，不知怎么感谢您。

lzjexp

chxw68 发表于 2016-11-10 15:35

怎么送花呀？没找到地方呢

lzjexp

是不是因为我没有鲜花可送啊

chxw68

lzjexp 发表于 2016-11-10 16:27
怎么送花呀？没找到地方呢

点击右下方[评分]。