- 帖子
- 976
- 主題
- 7
- 精華
- 0
- 積分
- 1018
- 點名
- 0
- 作業系統
- Win10
- 軟體版本
- Office 2016
- 閱讀權限
- 50
- 性別
- 男
- 註冊時間
- 2013-4-19
- 最後登錄
- 2026-5-26
|
回復 3# 44754875
請測試看看，謝謝。
Sub test()
Dim WB, Arr, Brr, xD, Ar, a, a1, fc%, x%, fn$, n%, i&, j%, iPos%, iLen%, iPos1%
Application.ScreenUpdating = False: Application.DisplayAlerts = False
Application.AskToUpdateLinks = False
Set xD = CreateObject("Scripting.Dictionary")
Brr = Sheets(1).Range([原始!d1], [原始!d65536].End(3))
With Sheets(2)
If .FilterMode Then .ShowAllData
.[d1].Resize(UBound(Brr)) = Brr
.[d1].Resize(UBound(Brr)).Font.ColorIndex = 1
End With
With Application.FileDialog(msoFileDialogOpen)
.InitialFileName = "D:\"
.AllowMultiSelect = True
.Show
fc = .SelectedItems.Count
If fc = 0 Then Exit Sub
Tm = Timer
For x = 1 To fc
FPath = .SelectedItems(x)
Set WB = Workbooks.Open(FPath)
With Sheets(1)
If .FilterMode Then .ShowAllData
Arr = .Range("d1:d" & .[d65536].End(3).Row)
For i = 2 To UBound(Arr)
Ar = Split(Arr(i, 1), Chr(10))
For j = 0 To UBound(Ar)
a = Split(Ar(j), ":")(0): a1 = Split(Ar(j), ":")(1): xD(a & "") = a1
Next
Next
End With
WB.Close
For i = 2 To UBound(Brr)
Ar = Split(Brr(i, 1), Chr(10))
For j = 0 To UBound(Ar)
a = Split(Ar(j), ":")(0): a1 = Split(Ar(j), ":")(1)
If xD.Exists(a & "") Then
If a1 <> xD(a & "") Then
Sheets(2).Cells(i, 4) = Replace(Cells(i, 4), a1, "更新-" & xD(a & ""))
End If
End If
Next
Next
xD.RemoveAll
Next
End With
With Sheets(2)
Arr = .Range("d1:d" & .[d65536].End(3).Row)
For i = 2 To UBound(Arr)
Ar = Split(Arr(i, 1), Chr(10))
For j = 0 To UBound(Ar)
a = Split(Ar(j), ":")(0): a1 = Split(Ar(j), ":")(1)
iPos = InStr(a1, "更新-"): iLen = Len(a1) + 5: iPos1 = InStr(Cells(i, 4), a)
If iPos > 0 Then: .Cells(i, 4).Characters(iPos1, iLen).Font.ColorIndex = 3
Next
Next
End With
Application.ScreenUpdating = True: Application.DisplayAlerts = True
Application.AskToUpdateLinks = True
MsgBox "執行完成" & Timer - Tm & " 秒"
End Sub |
|
發表於 2021-7-10 15:06
| 
