|
[广告] VBA代码宝 - VBA编程加强工具 · VBA代码随查随用 · 内置多项VBA编程加强工具 ★ 免费下载 ★ ★ 使用手册★
'3楼附件,,,
Option Explicit
Const NUM As Long = 16 ^ 5 '假设csv文件最大行
Sub test()
Dim arr, brr, pth As String, cnt As Long, t, tm
Dim i As Long, j As Long, m As Long, p As Long
Dim a As Long, b As Long, s As String
ReDim arr(1 To NUM, 1 To 3) As String
tm = Timer
pth = ThisWorkbook.Path & "\"
With GetObject(pth & "then.xlsx")
brr = .Sheets("Customer").[a1].CurrentRegion.Offset(1).Resize(, 3)
.Close False
End With
For i = 1 To UBound(brr, 1) - 1: brr(i, 3) = "b": Next
Debug.Print 1, Timer - tm, UBound(brr, 1) - 1
Open pth & "now.csv" For Input As #1
Do
Line Input #1, t
If Len(t) = 0 Then Exit Do
t = Replace(t, """", vbNullString)
t = Split(t, ",")
cnt = cnt + 1: arr(cnt, 1) = t(0)
arr(cnt, 2) = t(1): arr(cnt, 3) = "a"
Loop Until EOF(1)
Close #1
Debug.Print 2, Timer - tm, cnt
ReDim crr(1 To cnt + UBound(brr, 1), 1 To 3)
Call mdata(arr, crr, 2, cnt, m)
Call mdata(brr, crr, 1, UBound(brr, 1) - 1, m)
Debug.Print 3, Timer - tm, m
Call qsort(crr, CLng(1), m, 1)
p = 1: cnt = 0
For i = 1 To m
If crr(i, 1) <> crr(i + 1, 1) Then
Call qsort(crr, p, i, 2)
For j = p To i
If crr(j, 3) = "a" Then a = 1 Else b = 1
If crr(j, 1) <> crr(j + 1, 1) Or crr(j, 2) <> crr(j + 1, 2) Then
If a = 1 And b = 0 Then 'now有,then无
s = "delete"
ElseIf a = 0 And b = 1 Then 'now无,then有
s = "add"
End If
If Len(s) > 0 Then
cnt = cnt + 1
crr(cnt, 1) = crr(j, 1): crr(cnt, 2) = crr(j, 2): crr(cnt, 3) = s
End If
a = 0: b = 0: s = vbNullString
End If
Next
p = i + 1
End If
Next
Debug.Print 4, Timer - tm
If cnt < 16 ^ 5 Then
With [a2]
.Resize(Rows.Count - 1, 3).ClearContents
If cnt > 0 Then .Resize(cnt, 3) = crr
End With
Else
'输出为csv文件
End If
Debug.Print 5, Timer - tm, cnt
End Sub
Sub mdata(arr, brr, first, last, m)
Dim i As Long, j As Long
For i = first To last
m = m + 1
For j = 1 To 3: brr(m, j) = arr(i, j): Next
Next
End Sub
Sub qsort(arr, first, last, key)
Dim i As Long, j As Long, x As String, t As String
i = first: j = last: x = arr((first + last) / 2, key)
While i <= j
While StrComp(arr(i, key), x, vbTextCompare) = -1: i = i + 1: Wend
While StrComp(x, arr(j, key), vbTextCompare) = -1: j = j - 1: Wend
If i <= j Then
t = arr(i, 1): arr(i, 1) = arr(j, 1): arr(j, 1) = t
t = arr(i, 2): arr(i, 2) = arr(j, 2): arr(j, 2) = t
t = arr(i, 3): arr(i, 3) = arr(j, 3): arr(j, 3) = t
i = i + 1: j = j - 1
End If
Wend
If first < j Then Call qsort(arr, first, j, key)
If i < last Then Call qsort(arr, i, last, key)
End Sub |
评分
-
1
查看全部评分
-
|