根据日期更新其他工作薄数据

chyidc

现在我有2个工作薄，text1和text2，text1中的数据每天都会增加（更新）我想在text2中添加代码，限定条件为text2中Sheet1最后一行，然后能根据日期自动复制text1中Sheet1的更新数据。

这里只是简单举个例子，实际还有很多数据。
自己找了点代码，但是有错误。
希望大侠们多多帮忙，非常感谢
帮助.zip (33.15 KB, 下载次数: 3)

2013-12-6 19:00 上传

点击文件名下载附件

zhaogang1960

text2中的所有日期都将更新text1中当日的数据
请测试：

1. Sub Getdate()
   
2.     Dim cnn As Object, SQL As String
   
3.     Dim arr, s$, i%
   
4.     arr = Range("A1:H1")
   
5.     For i = 2 To UBound(arr, 2)
   
6.         s = s & ",a." & arr(1, i) & "=b." & arr(1, i)
   
7.     Next
   
8.     Set cnn = CreateObject("adodb.connection")
   
9.     cnn.Open "Provider=Microsoft.Ace.OLEDB.12.0;Extended Properties=Excel 12.0;Data Source=" & ThisWorkbook.FullName
   
10.     SQL = "update [Excel 12.0;imex=0;Database=" & ThisWorkbook.Path & "\text1.xlsx].[Sheet1$] a,[Sheet1$] b set " & Mid(s, 2) & " where a.日期=b.日期"
    
11.     cnn.Execute SQL
    
12.     cnn.Close
    
13.     Set cnn = Nothing
    
14. End Sub
    

复制代码

zhaogang1960

请注意，如果text1中没有text2中的日期，则不会添加新记录
请看附件
帮助.rar (28.78 KB, 下载次数: 17)

2013-12-6 19:20 上传

点击文件名下载附件

chyidc

zhaogang1960 发表于 2013-12-6 19:20
请注意，如果text1中没有text2中的日期，则不会添加新记录
请看附件

赵老师，这代码运行怎么没有反应呢？

zhaogang1960

chyidc 发表于 2013-12-6 19:31
赵老师，这代码运行怎么没有反应呢？

请看演示：

zhaogang1960

chyidc 发表于 2013-12-6 19:31
赵老师，这代码运行怎么没有反应呢？

难道你不是要更新数据，而是要在第一个2012-4-2行前面插入一行，再把数据复制过来？

zhaogang1960

在text1查找日期，如果找到，则在该行插入text2最后一行数据：

1. Sub Macro1()
   
2.     Dim rng As Range, c As Range
   
3.     Application.ScreenUpdating = False
   
4.     Set rng = Range("a" & Rows.Count).End(xlUp).EntireRow
   
5.     With Workbooks.Open(ThisWorkbook.Path & "\text1.xlsx")
   
6.          With .Sheets("Sheet1")
   
7.             Set c = .[a:a].Find(rng.Cells(1).Value, LookIn:=xlFormulas, lookat:=xlWhole)
   
8.             If Not c Is Nothing Then
   
9.                 rng.Copy
   
10.                 c.Insert Shift:=xlDown
    
11.             End If
    
12.          End With
    
13.         .Close True
    
14.     End With
    
15.     Application.CutCopyMode = False
    
16.     Application.ScreenUpdating = True
    
17.     MsgBox "ok"
    
18. End Sub

复制代码

chyidc

zhaogang1960 发表于 2013-12-6 19:41
难道你不是要更新数据，而是要在第一个2012-4-2行前面插入一行，再把数据复制过来？

感谢赵老师前面的代码，是我自己表述有误了。
我的意思是想在text2的表下面，增加text1中的数据，日期比text2中最后的日期新的。
如text2中最后一行是2012/2/1起始的，那么在它下面增加text1中2012/2/1后面日期的数据
text1里面是是10列数据（日期--备注），text2里面只要8列（日期--单价）
没有数据更新，则无提示
有数据更新，则msgbox提示，2012/2/1更新？条，2012/2/4更新？条
不知道我现在的表述是否清楚了？麻烦老师了，谢谢

chyidc

zhaogang1960 发表于 2013-12-6 19:51
在text1查找日期，如果找到，则在该行插入text2最后一行数据：

好，麻烦老师了

zhaogang1960

chyidc 发表于 2013-12-6 19:52
感谢赵老师前面的代码，是我自己表述有误了。
我的意思是想在text2的表下面，增加text1中的数据，日期比 ...

请测试：

1. Sub Getdate()
   
2.     Dim cnn As Object, rs As Object, SQL As String
   
3.     Set cnn = CreateObject("adodb.connection")
   
4.     Set rs = CreateObject("adodb.recordset")
   
5.     cnn.Open "Provider=Microsoft.Ace.OLEDB.12.0;Extended Properties=Excel 12.0;Data Source=" & ThisWorkbook.Path & "\text1.xlsx"
   
6.     SQL = "select " & Join([a1:h1&""], ",") & " from [Sheet1$] where 日期>#" & Range("a" & Rows.Count).End(xlUp) & "#"
   
7.     rs.Open SQL, cnn, 1, 3
   
8.     If rs.RecordCount > 0 Then
   
9.         SQL = "select 日期,count(*) from  [Sheet1$] where 日期>#" & Range("a" & Rows.Count).End(xlUp) & "# group by 日期"
   
10.         Range("a" & Rows.Count).End(xlUp).Offset(1).CopyFromRecordset rs
    
11.         Set rs = CreateObject("adodb.recordset")
    
12.         rs.Open SQL, cnn, 1, 3
    
13.         For i = 1 To rs.RecordCount
    
14.             s = s & vbCrLf & rs.Fields(0).Value & "更新" & rs.Fields(1).Value & "条"
    
15.             rs.MoveNext
    
16.         Next
    
17.         MsgBox s
    
18.     End If
    
19.     rs.Close
    
20.     cnn.Close
    
21.     Set rs = Nothing
    
22.     Set cnn = Nothing
    
23. End Sub
    

复制代码