请教如何实行提取2个工作簿差异(月份环比)数据放在新工作表中？

banzige

如图为例，每个月都有一张账单工作表，订单号是唯一，不同月份订单数量有新开通或终止、费用会发生变化，实际每个月数据条数达14000条左右，目前只会用vlookup查询找出差异后复制到相应工作表，苦于每个月重复操作很繁琐，所以来请教下如何用VBA实行自动完成这些操作，望大哥们指点。

补充：环比差异数据直接提取放到2月账单后面相应工作表；费用类型字段是固定不变的，不会新增。

LIUZHU

我就在想，应该是有一个汇总表，查找对比每个月的表。比如当前的汇总表是一月的数据，那么现在查找对比2月的表，如果新增的订单，那么则补充进汇总表，如果旧订单，那么就对比数据是否发生变化。如果发生变化了，就更新汇总表的对应该订单数据。
还有一个问题，费用A、费用B、费用C、费用D、费用E这些字段是否是固定不变的，还是会新增费用F、费用G这些字段呢？

banzige

LIUZHU 发表于 2024-3-14 16:18
我就在想，应该是有一个汇总表，查找对比每个月的表。比如当前的汇总表是一月的数据，那么现在查找对比2月 ...

谢谢，没有汇总表，环比差异数据直接提取放到2月账单后面相应工作表；费用类型字段是固定不变的，不会新增。

LIUZHU

如果在每个月的新表中做对比的话，那么是不要将代码每次都复制一遍到新表？

banzige

LIUZHU 发表于 2024-3-14 16:27
如果在每个月的新表中做对比的话，那么是不要将代码每次都复制一遍到新表？

是的~~~~~~~~~~~~~~~~~~~~

fzxba

测试.zip (35.86 KB, 下载次数: 5)

2024-3-14 19:51 上传

点击文件名下载附件

fzxba

1. Sub test1() ' 999帖 灌水
   
2.   
   
3.   Dim f As String
   
4.   
   
5. '  With Application.FileDialog(msoFileDialogOpen)
   
6. '    .InitialFileName = ThisWorkbook.Path
   
7. '    With .Filters
   
8. '      .Clear
   
9. '      .Add "Excel File(s)", "*.xls*"
   
10. '    End With
    
11. '    .AllowMultiSelect = False
    
12. '    If .Show Then f = .SelectedItems(1) Else Exit Sub
    
13. '  End With
    
14.   
    
15.   f = ThisWorkbook.Path & "\一月账单.xlsx"
    
16.   If Dir(f) = "" Then MsgBox f & " 不存在！", 64: Exit Sub
    
17.   
    
18.   Application.ScreenUpdating = False
    
19.   
    
20.   'Dim Conn As New ADODB.Connection, rs As New ADODB.Recordset
    
21.   Dim Conn As Object, rs As Object
    
22.   Dim strConn As String, SQL As String, s As String
    
23.   Dim A As String, B As String, C As String
    
24.   Dim ar, br, i As Long, j As Long, k As Long, n As Double
    
25.   
    
26.   Set Conn = CreateObject("ADODB.Connection")
    
27.   Set rs = CreateObject("ADODB.Recordset")
    
28.   
    
29.   s = "Excel 12.0;HDR=YES;Database="
    
30.   If Application.Version < 12 Then
    
31.     s = Replace(s, "12.0", "8.0")
    
32.     strConn = "Provider=Microsoft.Jet.OLEDB.4.0;Extended Properties=Excel 8.0;Data Source="
    
33.   Else
    
34.     strConn = "Provider=Microsoft.ACE.OLEDB.12.0;Extended Properties=Excel 12.0;Data Source="
    
35.   End If
    
36.   Conn.Open strConn & ThisWorkbook.FullName
    
37.   
    
38.   A = "SELECT * FROM [" & s & f & "].[Sheet1$A1:G] WHERE LEN(订单号) "
    
39.   With Sheet1
    
40.     i = .Cells(.Rows.Count, 1).End(xlUp).Row
    
41.     B = "SELECT * FROM [" & .Name & "$A1:G" & i & "]"
    
42.     C = "SELECT 订单号 FROM [" & s & f & "].[Sheet1$A1:A] WHERE LEN(订单号) UNION SELECT 订单号 FROM [" & .Name & "$A1:A" & i & "]"
    
43.   End With
    
44.   
    
45.   SQL = "SELECT a.*,b.* FROM ((" & C & ") c LEFT JOIN (" & A & ") a ON a.订单号=c.订单号) LEFT JOIN (" & B & ") b ON b.订单号=c.订单号"
    
46.   
    
47.   'rs.Open SQL, Conn, adOpenKeyset, adLockOptimistic
    
48.   rs.Open SQL, Conn, 1, 3
    
49.   
    
50.   With Sheet2.Range("A1")
    
51.     .Resize(Rows.Count - .Row, 20).Clear
    
52.     For j = 0 To rs.Fields.Count - 1
    
53.       If j > 6 Then
    
54.         .Offset(0, j) = Replace(rs.Fields(j).Name, ".", "_")
    
55.       Else
    
56.         .Offset(0, j) = Mid(rs.Fields(j).Name, 3)
    
57.       End If
    
58.     Next
    
59.     .Offset(1).CopyFromRecordset rs
    
60.    
    
61.     With .CurrentRegion
    
62.       C = .Parent.Name & "$" & .Address(0, 0)
    
63.       ar = Application.Rept(.Rows(1).Offset(, 0).Resize(, 7).Value, 1)
    
64.       A = "SELECT `" & Join(ar, "`,`") & "` FROM [" & C & "] WHERE `" & .Cells(8).Value & "` IS NULL"
    
65.       br = Application.Rept(.Rows(1).Offset(, 7).Resize(, 7).Value, 1)
    
66.       B = "SELECT `" & Join(br, "`,`") & "` FROM [" & C & "] WHERE `" & .Cells(1).Value & "` IS NULL"
    
67.       ar = .Value
    
68.     End With
    
69.   End With
    
70.   
    
71.   k = 1
    
72.   ar(k, 8) = "增减"
    
73.   br = Split("增加 ,减少 ", ",")
    
74.   For i = 2 To UBound(ar)
    
75.     If Trim(ar(i, 1)) = Trim(ar(i, 8)) Then
    
76.       If Val(ar(i, 7)) - Val(ar(i, 14)) <> 0 Then
    
77.         k = k + 1
    
78.         ar(k, 1) = ar(i, 1)
    
79.         ar(k, 8) = vbNullString
    
80.         For j = 2 To 6
    
81.           ar(k, j) = ar(i, j + 7)
    
82.           n = Val(ar(i, j)) - Val(ar(i, j + 7))
    
83.           If n Then ar(k, 8) = ar(k, 8) & ar(1, j) & br(-CInt((n > 0)))
    
84.         Next
    
85.         ar(k, j) = ar(i, j + 7)
    
86.       End If
    
87.     End If
    
88.   Next
    
89.   
    
90.   With Sheet4
    
91.     .UsedRange.Offset(1).ClearContents
    
92.     .Range("A2").CopyFromRecordset Conn.Execute(A)
    
93.   End With
    
94.   
    
95.   With Sheet3
    
96.     .UsedRange.Offset(1).ClearContents
    
97.     .Range("A2").CopyFromRecordset Conn.Execute(B)
    
98.   End With
    
99.   
    
100.   With Sheet2
     
101.     .UsedRange.Offset(0).ClearContents
     
102.     .Range("A1").Resize(k, 8) = ar
     
103.   End With
     
104.   
     
105.   rs.Close
     
106.   Set rs = Nothing
     
107.   Conn.Close
     
108.   Set Conn = Nothing
     
109.   
     
110.   Application.ScreenUpdating = True
     
111.   Beep
     
112. End Sub

复制代码