[發問] 依條件複製不同欄位資料與尋找取代

b9208

以下程式由錄製修改，資料幾千筆，執行時間需要幾分鐘，請教是否有精進程式可以縮短執行時間？
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

b9208

回復 1# b9208
非常抱歉
由於產生亂碼，所以重新以檔案上傳。
程序由錄製修改，資料幾千筆，執行時間需要幾分鐘，請教是否有精進程展式可以縮短執行時間？
程式碼請看附檔模組
q1.rar (21.01 KB)

下載次數: 13

2020-8-22 10:48

n7822123

回復 2# b9208

用Cell儲存格一個一個傳值會很慢

因為Cell是個物件，佔不少儲存位元空間，裡面包含了欄寬、列高、顏色、格式、位置.....一連串的資料

所以先把儲存格的"值"丟給記憶體(陣列)，然後做處理

處理完再一次丟回給儲存格，這方式效率比較高 (記憶體處理位元速度也會比轉盤式磁碟快)

第2段程式已經是高效的寫法，我是想不到如何可優化效率了，只幫你簡化程式碼

然後你給的資料頁，A欄沒東西，所以前半段沒法執行到~ 我自己添加流水號測試

程式如下

Sub main()
Application.ScreenUpdating = False
Worksheets("輸出").Activate
Ci = Array(, 2, 3, 4, 5, 6, 7, 8, 18, 19, 20, 22, 22, 23, 23)
Set Rg = [資料!A1048576].End(xlUp)
If Rg.Row = 1 Then Exit Sub
Arr = Range([資料!AD6], Rg)
Brr = [A5].Resize(UBound(Arr), 15)
[A2] = [資料!A2]
For R = 1 To UBound(Brr): For C = 1 To 14
    If C <= 10 Then Brr(R, C) = Arr(R, Ci(C))
    If C = 11 Or C = 13 Then Brr(R, C) = Left(Arr(R, Ci(C)), 8)
    If C = 12 Or C = 14 Then Brr(R, C) = Right(Arr(R, Ci(C)), 5)
Next C: Next R
With [A5].Resize(UBound(Brr), 15)  'A~O欄填值+劃框線
    .Value = Brr
    .Borders.LineStyle = xlContinuous
End With
With [A5].Resize(UBound(Brr), 10)   'A~J欄做排序
    .Sort key1:=.Item(2), key2:=.Item(10), Header:=xlNo
End With
With [H5].Resize(UBound(Brr), 2)   'H、I欄做取代
    .Replace "*AA*", "AAA"
    .Replace "*BBB*", "BBB"
    .Replace "*CC*", "CCC"
    .Replace "*DDD*", "DDD"
    .Replace "*EEE*", "DDD"
    .Replace "*FFF*", "FFF"
    .Replace "*GGG*", "GGG"
    .Replace "*HH*", "GGG"
    .Replace "*MM*", "MMM"
    .Replace "*LLL*", "LLL"
    .Replace "*QQQ*", "LLL"
    .Replace "*NNN*", "NNN"
    .Replace "*TTT*", "NNN"
End With
End Sub

測試檔案如下

q1+.rar (21.58 KB)

下載次數: 15

2020-8-22 13:45

b9208

回復 3# n7822123
請問下述句子 Arr = Range([資料！AD6], Rg) 中〞AD6〞是指什麼？資料工作表AD6是空白。感謝指導。
Set Rg = [資料!A1048576].End(xlUp)
If Rg.Row = 1 Then Exit Sub
Arr = Range([資料!AD6], Rg)
Brr = [A5].Resize(UBound(Arr), 15)

n7822123

回復 4# b9208


是參考你的原程式部分，下圖

我認為你是把簡化過的資料丟上來，實際還需要多判斷AD那一欄的值

所以我資料取的範圍大一點~~避免你要改，沒法判斷

現在看來是一個 美麗的誤會 ?

下載 (16.51 KB)

2020-8-22 16:51

b9208

回復 5# n7822123
非常抱歉，沒有修訂到。
原檔案共有52欄(AZ)，依據AD欄有資料，則copy需要欄位資料。
.cells(i, "AD") <> "" Then 應修改為 .cells(i, "T") <> "" Then
請問如依實際檔案A~AZ欄位，依據“AD”欄位有資料，則copy欄位如下：
Ci = Array(, 2, 3, 4, 5, 6, 7, 8, 28, 29, 30, 32, 32, 33, 33)
請問如何修訂

n7822123

回復 6# b9208

請問如依實際檔案A~AZ欄位，依據“AD”欄位有資料，則copy欄位如下：
Ci = Array(, 2, 3, 4, 5, 6, 7, 8, 28, 29, 30, 32, 32, 33, 33)
請問如何修訂

33欄到AG去了，來源陣列Arr要取資料到AG欄

並用第30欄(AD)判斷

如果只改來源資料的位置，輸出的欄位都一樣

修改程式如下 (僅截一小段說明)

Sub main()
Application.ScreenUpdating = False
Worksheets("輸出").Activate
Ci = Array(, 2, 3, 4, 5, 6, 7, 8, 28, 29, 30, 32, 32, 33, 33)
Set Rg = [資料!A1048576].End(xlUp)
If Rg.Row = 1 Then Exit Sub
Arr = Range([資料!AG6], Rg)
Brr = [A5].Resize(UBound(Arr), 15)
[A2] = [資料!A2]
For R = 1 To UBound(Brr): For C = 1 To 14
   If Arr(R, 30) <> "" Then
        If C <= 10 Then Brr(R, C) = Arr(R, Ci(C))
        If C = 11 Or C = 13 Then Brr(R, C) = Left(Arr(R, Ci(C)), 8)
        If C = 12 Or C = 14 Then Brr(R, C) = Right(Arr(R, Ci(C)), 5)
    End If
Next C: Next R
...
...
...

b9208

回復 7# n7822123
非常感謝，執行OK。
但有一個問題，輸出中框線列數與資料列數相同，也就是輸出中沒有資料列數也劃框線。
另、請教如於執行前，先清除輸出標題列以下儲存格之內容、框線及填滿顏色，不用.Delete方法，有其他方法可以達成？ q2.rar (21.7 KB)

下載次數: 8

2020-8-22 21:37

n7822123

回復 8# b9208

但有一個問題，輸出中框線列數與資料列數相同，也就是輸出中沒有資料列數也劃框線。

因為有條件篩選後，資料列數與輸出列數會變成不一樣了，這剛剛改給你時沒考慮到

所以我新增 "Ro" 變數來紀錄篩選過後的列數

另、請教如於執行前，先清除輸出標題列以下儲存格之內容、框線及填滿顏色，不用.Delete方法，有其他方法可以達成？

用Clear 方法即可清除，我會把修改的地方用紅色表示

程式如下

Sub main()
Application.ScreenUpdating = False
Worksheets("輸出").Activate
Ci = Array(, 2, 3, 4, 5, 6, 7, 8, 18, 19, 20, 22, 22, 23, 23)
Set Rg = [資料!A1048576].End(xlUp)
If Rg.Row = 1 Then Exit Sub
[A4].CurrentRegion.Resize(, 15).Offset(1).Clear
Arr = Range([資料!W6], Rg)
Brr = [A5].Resize(UBound(Arr), 15)
[A2] = [資料!A2]
For R = 1 To UBound(Brr)
  If Arr(R, 20) <> "" Then
      Ro = Ro + 1
      For C = 1 To 14
            If C <= 10 Then Brr(Ro, C) = Arr(R, Ci(C))
            If C = 11 Or C = 13 Then Brr(Ro, C) = Left(Arr(R, Ci(C)), 8)
            If C = 12 Or C = 14 Then Brr(Ro, C) = Right(Arr(R, Ci(C)), 5)
      Next C
  End If
Next R
With [A5].Resize(Ro, 15)  'A~O欄填值+劃框線
    .Value = Brr
    .Borders.LineStyle = xlContinuous
End With
With [A5].Resize(Ro, 14)   'A~J欄做排序
    .Sort key1:=.Item(2), key2:=.Item(10), Header:=xlNo
End With
With [H5].Resize(Ro, 2)   'H、I欄做取代
    .Replace "*AA*", "AAA"
    .Replace "*BBB*", "BBB"
    .Replace "*CC*", "CCC"
    .Replace "*DDD*", "DDD"
    .Replace "*EEE*", "DDD"
    .Replace "*FFF*", "FFF"
    .Replace "*GGG*", "GGG"
    .Replace "*HH*", "GGG"
    .Replace "*MM*", "MMM"
    .Replace "*LLL*", "LLL"
    .Replace "*QQQ*", "LLL"
    .Replace "*NNN*", "NNN"
    .Replace "*TTT*", "NNN"
End With
End Sub

檔案如下

q2+2.rar (20.96 KB)

下載次數: 11

2020-8-22 23:01

b9208

回復 9# n7822123
非常感謝指導
問題解決了