返回列表 上一主題 發帖

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

本帖最後由 n7822123 於 2020-8-22 13:48 編輯

回復 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)
程式是依需求寫的,需求表達不清楚
或者沒有上傳附件,愛莫能助

TOP

本帖最後由 n7822123 於 2020-8-22 16:54 編輯

回復 4# b9208


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

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

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

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


程式是依需求寫的,需求表達不清楚
或者沒有上傳附件,愛莫能助

TOP

本帖最後由 n7822123 於 2020-8-22 20:06 編輯

回復 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
...
...
...
程式是依需求寫的,需求表達不清楚
或者沒有上傳附件,愛莫能助

TOP

本帖最後由 n7822123 於 2020-8-22 23:05 編輯

回復 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)
程式是依需求寫的,需求表達不清楚
或者沒有上傳附件,愛莫能助

TOP

本帖最後由 n7822123 於 2020-8-23 14:53 編輯

回復 11# 准提部林

啊~感謝準大糾錯  

我把原程式 的這行 .Range("a5:o" & [j1048576].End(xlUp).Row).Select

看成是A~J欄了   ,應該是A~O才對 ,看太快看錯了.....

原PO還沒發現到..... 程式修改如下(因為都是A~O,與上面合併)


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
    .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
程式是依需求寫的,需求表達不清楚
或者沒有上傳附件,愛莫能助

TOP

        靜思自在 : 人生沒有所有權,只有生命的使用權。
返回列表 上一主題