[已解决]求大神编写一个自动更新数据的代码

lindadada

求大神编写一个自动更新数据的代码

最佳答案

月排行榜 / 总排行榜

chart888

2017-6-7 10:21

1. Private Sub CommandButton2_Click()
   
2. Dim Arr, i&, Myr&, r&, Brr
   
3. Dim d, k, t, K1, K2
   
4. K1 = 0: K2 = 0
   
5. Set d = CreateObject("Scripting.Dictionary")
   
6. Application.ScreenUpdating = False
   
7. strFilename = Application.GetOpenFilename(, , "请选择需要导入的文件")
   
8.     If strFilename = "False" Then
   
9.         Exit Sub
   
10.     End If
    
11.         FileN = Dir(strFilename)
    
12.     Workbooks.OpenText Filename:=strFilename, DataType:=xlDelimited, Tab:=True
    
13.         strDataBook = ActiveWorkbook.Name
    
14.         With ActiveSheet
    
15.             If .Cells(1, 1).Value = "序号" And .Cells(1, 2).Value = "新增日期" And .Cells(1, 3).Value = "登录日期" Then
    
16.                 Myr = .Cells(Rows.Count, 1).End(xlUp).Row
    
17.                 Brr = .Range("A3:M" & Myr)
    
18.                 Workbooks(strDataBook).Close savechanges:=False
    
19.             Else
    
20.                 Workbooks(strDataBook).Close savechanges:=False
    
21.                 MsgBox " 您打开文件不正确，请确认！"
    
22.                 Exit Sub
    
23.             End If
    
24.         End With
    
25. With ActiveSheet
    
26.     Arr = .[A9].CurrentRegion
    
27.     For i = 1 To UBound(Arr)
    
28.         d(Arr(i, 4)) = 6 + i
    
29.     Next
    
30.     r = .Cells(Rows.Count, 4).End(xlUp).Row
    
31.     If r = 7 Then r = r + 1
    
32. For i = 1 To UBound(Brr)
    
33.     If d.exists(Brr(i, 4)) Then
    
34.         k = d(Brr(i, 4))
    
35.         .Cells(k, 3) = Brr(i, 3): .Cells(k, 5) = Brr(i, 5): .Cells(k, 6) = Brr(i, 6)
    
36.         .Cells(k, 7) = Brr(i, 7): .Cells(k, 8) = Brr(i, 8): .Cells(k, 9) = Brr(i, 9)
    
37.         .Cells(k, 10) = Brr(i, 10): .Cells(k, 13) = Brr(i, 11)
    
38.         K1 = K1 + 1
    
39.     Else
    
40.         r = r + 1
    
41.         .Cells(r, 2) = Brr(i, 3): .Cells(r, 5) = Brr(i, 5): .Cells(r, 6) = Brr(i, 6)
    
42.         .Cells(r, 7) = Brr(i, 7): .Cells(r, 8) = Brr(i, 8): .Cells(r, 9) = Brr(i, 9)
    
43.         .Cells(r, 10) = Brr(i, 10): .Cells(r, 13) = Brr(i, 11): .Cells(r, 4) = Brr(i, 4)
    
44.         .Cells(r, 13) = Brr(i, 12): .Cells(r, 14) = Brr(i, 13)
    
45.         .Cells(r, 1) = r - 8
    
46.         K2 = K2 + 1
    
47.     End If
    
48. Next
    
49. With .Range("A7").CurrentRegion.Borders
    
50.     .LineStyle = xlContinuous
    
51.     .Weight = xlThin
    
52. End With
    
53.    With .Range("A7").CurrentRegion
    
54.         .VerticalAlignment = xlCenter
    
55.         .HorizontalAlignment = xlCenter
    
56.         .Font.Name = "微软雅黑"
    
57.         .Font.Size = 11
    
58.         .EntireColumn.AutoFit
    
59.     End With
    
60. End With
    
61. MsgBox Space(4) & "文件导入完成,请确认！" & Chr(10) _
    
62.         & Space(4) & "新增记录:" & K2 & Chr(10) _
    
63.         & Space(4) & "更新记录:" & K1
    
64. Application.ScreenUpdating = True
    
65. End Sub

复制代码

跳转到最佳答案楼层

chart888

1. Private Sub CommandButton2_Click()
   
2. Dim Arr, i&, Myr&, r&, Brr
   
3. Dim d, k, t, K1, K2
   
4. K1 = 0: K2 = 0
   
5. Set d = CreateObject("Scripting.Dictionary")
   
6. Application.ScreenUpdating = False
   
7. strFilename = Application.GetOpenFilename(, , "请选择需要导入的文件")
   
8.     If strFilename = "False" Then
   
9.         Exit Sub
   
10.     End If
    
11.         FileN = Dir(strFilename)
    
12.     Workbooks.OpenText Filename:=strFilename, DataType:=xlDelimited, Tab:=True
    
13.         strDataBook = ActiveWorkbook.Name
    
14.         With ActiveSheet
    
15.             If .Cells(1, 1).Value = "序号" And .Cells(1, 2).Value = "新增日期" And .Cells(1, 3).Value = "登录日期" Then
    
16.                 Myr = .Cells(Rows.Count, 1).End(xlUp).Row
    
17.                 Brr = .Range("A3:M" & Myr)
    
18.                 Workbooks(strDataBook).Close savechanges:=False
    
19.             Else
    
20.                 Workbooks(strDataBook).Close savechanges:=False
    
21.                 MsgBox " 您打开文件不正确，请确认！"
    
22.                 Exit Sub
    
23.             End If
    
24.         End With
    
25. With ActiveSheet
    
26.     Arr = .[A9].CurrentRegion
    
27.     For i = 1 To UBound(Arr)
    
28.         d(Arr(i, 4)) = 6 + i
    
29.     Next
    
30.     r = .Cells(Rows.Count, 4).End(xlUp).Row
    
31.     If r = 7 Then r = r + 1
    
32. For i = 1 To UBound(Brr)
    
33.     If d.exists(Brr(i, 4)) Then
    
34.         k = d(Brr(i, 4))
    
35.         .Cells(k, 3) = Brr(i, 3): .Cells(k, 5) = Brr(i, 5): .Cells(k, 6) = Brr(i, 6)
    
36.         .Cells(k, 7) = Brr(i, 7): .Cells(k, 8) = Brr(i, 8): .Cells(k, 9) = Brr(i, 9)
    
37.         .Cells(k, 10) = Brr(i, 10): .Cells(k, 13) = Brr(i, 11)
    
38.         K1 = K1 + 1
    
39.     Else
    
40.         r = r + 1
    
41.         .Cells(r, 2) = Brr(i, 3): .Cells(r, 5) = Brr(i, 5): .Cells(r, 6) = Brr(i, 6)
    
42.         .Cells(r, 7) = Brr(i, 7): .Cells(r, 8) = Brr(i, 8): .Cells(r, 9) = Brr(i, 9)
    
43.         .Cells(r, 10) = Brr(i, 10): .Cells(r, 13) = Brr(i, 11): .Cells(r, 4) = Brr(i, 4)
    
44.         .Cells(r, 13) = Brr(i, 12): .Cells(r, 14) = Brr(i, 13)
    
45.         .Cells(r, 1) = r - 8
    
46.         K2 = K2 + 1
    
47.     End If
    
48. Next
    
49. With .Range("A7").CurrentRegion.Borders
    
50.     .LineStyle = xlContinuous
    
51.     .Weight = xlThin
    
52. End With
    
53.    With .Range("A7").CurrentRegion
    
54.         .VerticalAlignment = xlCenter
    
55.         .HorizontalAlignment = xlCenter
    
56.         .Font.Name = "微软雅黑"
    
57.         .Font.Size = 11
    
58.         .EntireColumn.AutoFit
    
59.     End With
    
60. End With
    
61. MsgBox Space(4) & "文件导入完成,请确认！" & Chr(10) _
    
62.         & Space(4) & "新增记录:" & K2 & Chr(10) _
    
63.         & Space(4) & "更新记录:" & K1
    
64. Application.ScreenUpdating = True
    
65. End Sub

复制代码