更新進度，來源為多個檔案
有一CASE，是由許多部門一同合作，要負責整合各單位的進度真的是非常擾人，目前都用一個一個複製貼上，更新部分再自行標藍字，不能夠直接複製整個儲存格，因為一個儲存格有多個單位，所以只能付制儲存格內的內容，但是就會變回原格式，所以還要再標一次藍字，請教要怎麼樣可以自動抓取後更新[attach]33564[/attach]
[attach]33565[/attach]
[attach]33566[/attach]
[attach]33567[/attach]
[attach]33568[/attach] [b]回復 [url=http://forum.twbts.com/redirect.php?goto=findpost&pid=115782&ptid=23224]1#[/url] [i]44754875[/i] [/b]
方便可以提供來源和需求結果的檔案測試嗎? 謝謝 [b]回復 [url=http://forum.twbts.com/redirect.php?goto=findpost&pid=115787&ptid=23224]2#[/url] [i]samwang[/i] [/b]
來源檔案 [b]回復 [url=http://forum.twbts.com/redirect.php?goto=findpost&pid=115790&ptid=23224]3#[/url] [i]44754875[/i] [/b]
請測試看看，謝謝。
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 [b]回復 [url=http://forum.twbts.com/redirect.php?goto=findpost&pid=115793&ptid=23224]4#[/url] [i]samwang[/i] [/b]
A、B各別執行都成功，但是C 只有更新一筆，正確要更新兩筆資料
另外當同時選取A、B、C執行只有更新B、C的部分
[attach]33573[/attach] [b]回復 [url=http://forum.twbts.com/redirect.php?goto=findpost&pid=115797&ptid=23224]5#[/url] [i]44754875[/i] [/b]
我測試後無誤如附件，請再確認，謝謝。 [b]回復 [url=http://forum.twbts.com/redirect.php?goto=findpost&pid=115800&ptid=23224]6#[/url] [i]samwang[/i] [/b]
抱歉因為無權限下載，請問程式碼有修改嗎 回復 [url=http://forum.twbts.com/redirect.php?goto=findpost&pid=115800&ptid=23224]6#[/url] [i]samwang[/i] [/b]
[attach]33580[/attach][b]
我複製上面程式測試的檔案 [b]回復 [url=http://forum.twbts.com/redirect.php?goto=findpost&pid=115813&ptid=23224]8#[/url] [i]44754875[/i] [/b]
我的程式碼沒修改，
剛剛看了你上傳測試有問題的檔案才知道問題在於程式碼放錯地方，
請把程式碼放在一般模組執行就沒問題了，謝謝。 [b]回復 [url=http://forum.twbts.com/redirect.php?goto=findpost&pid=115814&ptid=23224]9#[/url] [i]samwang[/i] [/b]
太感謝了，成功了
頁:
[1]