VBA跨欄複製貼上值問題

excel vba

msmplayv121068 2018-07-07 16:52:41 ‧ 11844 瀏覽

分享至

請問該如何精簡以下巨集
Sub 巨集1()
Columns("B:C").Select
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues
Columns("G:J").Select
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues
Columns("N:O").Select
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues
Columns("S:V").Select
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues
Columns("Z:AA").Select
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues
Columns("AE:AH").Select
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues
Columns("AL:AM").Select
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues
Columns("AQ:AT").Select
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues
Columns("AX:AY").Select
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues
Columns("BC:BF").Select
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues
Columns("BJ:BK").Select
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues
Columns("BO:BR").Select
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues
Columns("BV:BW").Select
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues
Columns("CA:CD").Select
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues
End Sub

說明:
假設B5:CG20都是公式，我需要將黃底欄公式貼為值，只需保留白底欄公式即可。
目前只會錄製巨集方式一鍵完成，但遇到問題是如果有新增欄位或刪除欄位時，所有範圍欄位就要重新一一錄製。
想請問是否有什麼方法，可以指定想貼為值的標題欄寫語法達成
例如:只要B4:CG4，標題為"目標數量","目標金額","銷售數量","銷售金額","實際數量","實際金額"的欄均複製貼為值
或之類的~~不然每次只要遇到欄位調整，就要重新檢查真的非常麻煩~~

測試檔http://www.FunP.Net/845062

登入發表討論

直播研討會

{{ item.channelVendor }} {{ item.webinarstarted }} |

直播中

1 個回答

paicheng0111

iT邦大師 5 級 ‧ 2018-07-08 08:10:08

最佳解答

下面這段試試看，手邊沒有office，所以還沒測試過。

Sub test()
    dim myColumn as variant, i as variant, found as variant, firstAddress as string
    
    ' 要轉換為數值的欄位名稱'
    toValue = array("目標數量","目標金額","銷售數量","銷售金額","實際數量","實際金額")
    ' 欄位名稱位置'
    set myRng = Range("B4:CG4")

    for i = lbound(toValue) to ubound(toValue)
        on error resume next
        set found = myRng.find(what:=toValue(i), lookin:=xlValues, LookAt:=xlWhole)

        if not found is nothing then
            firstAddress = found.address
            
            do
                with range(found.offset(1), found.end(xldown))
                    .value = .value
                end with
                found = myRng.FindNext(found)
            loop while not found is nothing and found.address <> firstAddress
        end if
        on error goto 0
    next i
end sub

另外改一下本題的標籤為excel、vba會比較好。

回應 8
分享
檢舉

看更多先前的回應...收起先前的回應...

msmplayv121068 iT邦新手 4 級 ‧ 2018-07-08 13:51:25 檢舉

@pcw 又是你來幫我了!!哈~~~~~
測試結果無反應，然後我把on error resume next拿掉測試，以下這段:set found = myRng.find(what:=toValue(i), lookin:=xlValues, LookAt:=xlWhole)
出現錯誤訊息:執行階段錯誤:424:此處需要物件

不過你真的狠厲害耶，沒工具還能寫的出來，好佩服你喔!!

paicheng0111 iT邦大師 5 級 ‧ 2018-07-08 21:41:35 檢舉

你再試試看。
我把myRng = Range("B4:CG4")
改為set myRng = Range("B4:CG4")

最近久沒寫VBA，還是會犯低級錯誤。

msmplayv121068 iT邦新手 4 級 ‧ 2018-07-08 21:55:02 檢舉

@pcw 修改之後測試只有C、G:J、N以上幾欄有複製貼為值，B、O欄以後反黃欄仍為公式，好怪喔~~~

msmplayv121068 iT邦新手 4 級 ‧ 2018-07-08 21:56:37 檢舉

還有標籤已改喔!!謝謝提醒~~~~~~

paicheng0111 iT邦大師 5 級 ‧ 2018-07-09 06:45:58 檢舉

原來你的目標數量不只一個！
我再加一個do-loop，你試試看。

另外，excel、vba應該是2個標籤，而不是一個。
你應該先打excel按下enter之後，再打vba再按enter。

msmplayv121068 iT邦新手 4 級 ‧ 2018-07-09 21:11:12 檢舉

@pcw 哈~改好了改好了(標籤
不過試了do-loop居然還是一樣耶!!
只有C、G:J、N這幾欄有複製貼為值，B欄跟O欄以後反黃欄仍為公式，真的超奇怪的
而且怪是明明範圍是Range("B4:CG4")，執行後B欄卻完全沒動靜，而是從C欄開始複製貼為值?而且只執行到N欄?

paicheng0111 iT邦大師 5 級 ‧ 2018-07-09 21:43:39 檢舉

再改
found = myRng.FindNext(found)
為
set found = myRng.FindNext(found)

msmplayv121068 iT邦新手 4 級 ‧ 2018-07-09 22:27:35 檢舉

pcw 真的可以了耶!!!!實在太厲害了你~~~~~~~~~~~~~~~~~~~超級感謝你的!!!!!

登入發表回應

我要發表回答

立即登入回答

參賽組數

1064 組

團體組數

40 組

累計文章數

22195 篇

完賽人數

600 人

15th鐵人賽 16th鐵人賽 13th鐵人賽 14th鐵人賽 12th鐵人賽 11th鐵人賽鐵人賽 2019鐵人賽 javascript 2018鐵人賽 python 2017鐵人賽 windows php c# windows server linux css react vue.js

IT邦幫忙