Function Update1(ByVal FileName$) As Long
Dim ConnStr$, n&, SQLStr$, cnn As ADODB.Connection, rst As ADODB.Recordset
On Error GoTo lbEndSub
Sheet1.Activate
n = Range("B" & Columns(1).Rows.Count).End(xlUp).Row + 1
'?????
Range("B" & n, "B" & Columns(1).Rows.Count).EntireRow.Delete
ConnStr = "Provider=Microsoft.ACE.OLEDB.12.0;" & _
"Data Source=" & FileName & _
";Extended Properties=""Excel 12.0;HDR=YES;IMEX=1"";"
Set cnn = New ADODB.Connection
cnn.Open ConnStr
Set rst = New ADODB.Recordset
SQLStr = "SELECT DISTINCT * FROM [Sheet1$B1:M1000000] b WHERE b.CMND_HC NOT IN (SELECT a.CMND_HC FROM " & _
"[Excel 12.0;HDR=YES;IMEX=1;DATABASE=" & _
ThisWorkbook.FullName & "].[sheet1$] a)"
rst.Open SQLStr, cnn
Range("B" & n).CopyFromRecordset rst
Range("B" & n, "M" & Range("B" & Columns(1).Rows.Count).End(xlUp).Row).RemoveDuplicates 3, 0
Update1 = Range("B" & Columns(1).Rows.Count).End(xlUp).Row - n + 1
Range("A2").AutoFill Range("A2:A" & (n + Update1 - 1)), xlFillSeries
lbEndSub:
If Not rst Is Nothing Then
If rst.State = adStateOpen Then rst.Close
Set rst = Nothing
End If
If Not cnn Is Nothing Then
If cnn.State = adStateOpen Then cnn.Close
Set cnn = Nothing
End If
If Err.Number <> 0 Then MsgBox Err.Number & ": " & Err.Description, vbCritical
End Function
Function Update2(ByVal FileName$) As Long
Dim ConnStr$, SQLStr$, cnn As ADODB.Connection, rst As ADODB.Recordset, Fld As Field, ar1(), ar2()
Dim n&, i&, j&, k&, Chk As Boolean, PrevousRecord$
On Error GoTo lbEndSub
ConnStr = "Provider=Microsoft.ACE.OLEDB.12.0;" & _
"Data Source=" & FileName & _
";Extended Properties=""Excel 12.0;HDR=YES;IMEX=1"";"
Set cnn = New ADODB.Connection
cnn.Open ConnStr
Set rst = New ADODB.Recordset
SQLStr = "SELECT DISTINCT * FROM [sheet1$B1:M1000000] ORDER BY CMND_HC"
rst.Open SQLStr, cnn
n = Range("B" & Columns(1).Rows.Count).End(xlUp).Row
i = 1
ar1 = Sheet1.Range("B2:M" & n)
ReDim ar2(1 To 100000, 1 To UBound(ar1, 2))
Do While Not rst.EOF
Chk = False
For i = 1 To UBound(ar1)
If rst.Fields("CMND_HC").Value = PrevousRecord Then
Chk = True
Exit For
Else
For k = 1 To UBound(ar1)
If rst.Fields("CMND_HC").Value = ar1(k, 3) Then
Chk = True
Exit For
End If
Next
End If
Next
If Not Chk Then
j = j + 1
i = 1
For Each Fld In rst.Fields
ar2(j, i) = Fld.Value
i = i + 1
Next
PrevousRecord = ar2(j, 3)
End If
rst.MoveNext
Loop
Range("B" & (n + 1)).Resize(j, UBound(ar1, 2)) = ar2
Update2 = j
Range("A2").AutoFill Range("A2:A" & (n + j)), xlFillSeries
lbEndSub:
If Not rst Is Nothing Then
If rst.State = adStateOpen Then rst.Close
Set rst = Nothing
End If
If Not cnn Is Nothing Then
If cnn.State = adStateOpen Then cnn.Close
Set cnn = Nothing
End If
If Err.Number <> 0 Then MsgBox Err.Number & ": " & Err.Description, vbCritical
End Function
Sub test()
Dim FileName$, FDlg As FileDialog
Application.ScreenUpdating = False
Application.EnableEvents = False
Set FDlg = Application.FileDialog(msoFileDialogFilePicker)
FDlg.AllowMultiSelect = False
If FDlg.Show = 0 Then GoTo lbEndSub
FileName = FDlg.SelectedItems(1)
Application.ScreenUpdating = True
MsgBox Update1(FileName) & " records have been appended."
lbEndSub:
Set FDlg = Nothing
Application.ScreenUpdating = True
Application.EnableEvents = True
End Sub
