本帖最後由 b9208 於 2020-8-22 10:00 編輯
以下程式由錄製修改，資料幾千筆，執行時間需要幾分鐘，請教是否有精進程式可以縮短執行時間？
Sub main()
Application.ScreenUpdating = False
Set WS = Worksheets("資料")
Set WT = Worksheets("輸出")
K = 5
With WS
WT.Cells(2, "A") = .Cells(2, "A")
For i = 6 To .Cells(ActiveSheet.Rows.Count, "A").End(xlUp).Row
If .Cells(i, "AD") <> "" Then
WT.Cells(K, "A") = .Cells(i, "B")
WT.Cells(K, "B") = .Cells(i, "C")
WT.Cells(K, "C") = .Cells(i, "D")
WT.Cells(K, "D") = .Cells(i, "E")
WT.Cells(K, "E") = .Cells(i, "F")
WT.Cells(K, "F") = .Cells(i, "G")
WT.Cells(K, "G") = .Cells(i, "H")
WT.Cells(K, "H") = .Cells(i, "AB")
WT.Cells(K, "I") = .Cells(i, "AC")
WT.Cells(K, "J") = .Cells(i, "AD")
WT.Cells(K, "K") = Left(.Cells(i, "AF"), 8)
WT.Cells(K, "L") = Right(.Cells(i, "AF"), 5)
WT.Cells(K, "M") = Left(.Cells(i, "AG"), 8)
WT.Cells(K, "N") = Right(.Cells(i, "AG"), 5)
WT.Range("A" & K & ":O" & K).Select
Selection.Borders.LineStyle = xlContinuous
K = K + 1
End If
Next i
.Range("a5:o" & [j1048576].End(xlUp).Row).Select
Selection.Sort key1:=.[B5], key2:=.[J5], Header:=xlNo
End With
With WT
.Range("a5:o" & [j1048576].End(xlUp).Row).Select
Selection.Sort key1:=.[B5], key2:=.[J5], Header:=xlNo
.Range("h5:I" & [j1048576].End(xlUp).Row).Select
Selection.Replace What:="*AA*", Replacement:="AAA"
Selection.Replace What:="*BBB*", Replacement:="BBB"
Selection.Replace What:="*CC*", Replacement:="CCC"
Selection.Replace What:="*DDD*", Replacement:="DDD"
Selection.Replace What:="*EEE*", Replacement:="DDD"
Selection.Replace What:="*FFF*", Replacement:="FFF"
Selection.Replace What:="*GGG*", Replacement:="GGG"
Selection.Replace What:="*HH*", Replacement:="GGG"
Selection.Replace What:="*MM*", Replacement:="MMM"
Selection.Replace What:="*LLL*", Replacement:="LLL"
Selection.Replace What:="*QQQ*", Replacement:="LLL"
Selection.Replace What:="*NNN*", Replacement:="NNN"
Selection.Replace What:="*TTT*", Replacement:="NNN"
End With
End Sub |
發表於 2020-8-22 09:52
| 
