数据归纳汇总

CYZ凡星点点

求助如何在不清除 总单工作簿（资料）原有数据
将信息工作簿（单价）B列姓名右边 C列-E列内容
归纳汇总到总单工作簿（资料）第2行相同姓名下面空单元格处

3190496160

Sub 汇总信息()
Application.ScreenUpdating = False
Dim ar As Variant
Dim d As Object, dc As Object
Set d = CreateObject("scripting.dictionary")
lj = ThisWorkbook.Path & "\"
f = Dir(lj & "信息.xlsm")
If f = "" Then MsgBox "找不到信息.xlsm文件！": End
Set wb = Workbooks.Open(lj & f, 0)
ar = wb.Worksheets("单价").[a1].CurrentRegion
wb.Close False
With Sheets("资料")
    y = .Cells(1, Columns.Count).End(xlToLeft).Column
    For j = 1 To y Step 3
        d(.Cells(2, j).Value) = j
    Next j
    For i = 2 To UBound(ar)
        If ar(i, 2) <> "" Then
            lh = d(ar(i, 2))
            If lh <> "" Then
                 r = .Cells(Rows.Count, lh).End(xlUp).Row + 1
                 m = lh - 1
                 For j = 3 To 5
                    m = m + 1
                    .Cells(r, m) = ar(i, j)
                Next j
            End If
        End If
    Next i
End With
Application.ScreenUpdating = True
MsgBox "ok!"
End Sub

3190496160

文件夹.rar (262.34 KB, 下载次数: 23)

2024-2-9 13:52 上传

点击文件名下载附件

CYZ凡星点点

3190496160 发表于 2024-2-9 13:52

非常感谢老师，能不能增加判断功能同姓名下，已有日期时间相同的不复制，在次执行按钮也没有复制。

ykcbf1100

CYZ凡星点点 发表于 2024-2-9 14:03
非常感谢老师，能不能增加判断功能同姓名下，已有日期时间相同的不复制，在次执行按钮也没有复制。

单价表中部分支付对应汇总表中哪个字段，已支付或未支付？汇总表中看不到部分支付的字段

fzxba

1. Sub test1()
   
2. 
   
3.   Dim strFile As String
   
4. '  With Application.FileDialog(msoFileDialogOpen)
   
5. '    .InitialFileName = ThisWorkbook.Path
   
6. '    With .Filters
   
7. '      .Clear
   
8. '      .Add "Excel文件(xls*)", "*.xls*"
   
9. '    End With
   
10. '    .AllowMultiSelect = False
    
11. '    If .Show Then strFile = .SelectedItems(1) Else Exit Sub
    
12. '  End With
    
13. 
    
14.   strFile = ThisWorkbook.Path & "\信息.xlsm"
    
15.   If Dir(strFile) = "" Then MsgBox strFile & " 文件不存在！", 64: Exit Sub
    
16.   
    
17. '  Dim Conn As New ADODB.Connection, rs As New ADODB.Recordset
    
18.   Dim Conn As Object, rs As Object, Dic As Object, Dict As Object
    
19.   Dim strConn As String, SQL As String
    
20.   Dim ar, br, cr() As Long
    
21.   Dim i As Long, j As Long, pos As Long
    
22.   
    
23.   With Range("A1").CurrentRegion
    
24.     ar = Application.Rept(.Rows(2), 1)
    
25.     br = .Offset(2).Resize(366)
    
26.     ReDim cr(1 To UBound(ar))
    
27.   End With
    
28.   
    
29.   Set Dic = CreateObject("Scripting.Dictionary")
    
30.   Set Dict = CreateObject("Scripting.Dictionary")
    
31.   For j = 1 To UBound(ar) Step 3
    
32.     Dict.Add ar(j), j
    
33.     cr(j) = Cells(1, j).End(xlDown).Row - 2
    
34.     Set Dic(ar(j)) = CreateObject("Scripting.Dictionary")
    
35.     For i = 1 To cr(j)
    
36.       Dic(ar(j)).Add br(i, j), vbNullString
    
37.     Next
    
38.   Next
    
39.   
    
40.   Set Conn = CreateObject("ADODB.Connection")
    
41.   Set rs = CreateObject("ADODB.Recordset")
    
42.   If Application.Version < 12 Then
    
43.     strConn = "Provider=Microsoft.Jet.OLEDB.4.0;Extended Properties=Excel 8.0;Data Source="
    
44.   Else
    
45.     strConn = "Provider=Microsoft.ACE.OLEDB.12.0;Extended Properties=Excel 12.0;Data Source="
    
46.   End If
    
47.   Conn.Open strConn & strFile
    
48.   SQL = "SELECT * FROM  [单价$B1:E] WHERE 姓名 IS NOT NULL ORDER BY 姓名"
    
49.   rs.Open SQL, Conn, 1, 3
    
50.   
    
51.   ar = rs.GetRows()
    
52.   For j = 0 To UBound(ar, 2)
    
53.     If Dict.Exists(ar(0, j)) Then
    
54.       If Not Dic(ar(0, j)).Exists(ar(1, j)) Then
    
55.         pos = Dict(ar(0, j))
    
56.         cr(pos) = cr(pos) + 1
    
57.         For i = 1 To UBound(ar)
    
58.           br(cr(pos), pos + i - 1) = ar(i, j)
    
59.         Next
    
60.       End If
    
61.     End If
    
62.   Next
    
63.   Range("A13").Resize(WorksheetFunction.Max(cr), UBound(br, 2)) = br '改为 Range("A3")
    
64.   
    
65.   rs.Close
    
66.   Set rs = Nothing
    
67.   Conn.Close
    
68.   Set Conn = Nothing
    
69.   Set Dict = Nothing
    
70.   Set Dic = Nothing
    
71.   Beep
    
72. End Sub

复制代码

fzxba

综合整理一下再更新.zip (818.41 KB, 下载次数: 31)

2024-2-10 11:18 上传

点击文件名下载附件

3190496160

CYZ凡星点点 发表于 2024-2-9 14:03
非常感谢老师，能不能增加判断功能同姓名下，已有日期时间相同的不复制，在次执行按钮也没有复制。

写代码的过程中就行到，你可能会提出这样的要求，但是，因为不确定，所以也就没有考虑了

CYZ凡星点点

ykcbf1100 发表于 2024-2-9 15:36
单价表中部分支付对应汇总表中哪个字段，已支付或未支付？汇总表中看不到部分支付的字段

那是汇总表筛选，我只区分已支付就是结清，其他就未支付，当然也可以增加部分支付的条件。

ykcbf1100

CYZ凡星点点 发表于 2024-2-9 20:57
那是汇总表筛选，我只区分已支付就是结清，其他就未支付，当然也可以增加部分支付的条件。

你求助时应该说清楚。我在写代码时就卡在那里了，就没往下写。