iT邦幫忙

0

VBA跨欄複製貼上值問題

https://ithelp.ithome.com.tw/upload/images/20180707/20109231P5eLG2VQpY.png

請問該如何精簡以下巨集
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

1 個回答

0
paicheng0111
iT邦高手 3 級 ‧ 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

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

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

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

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

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

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

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

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

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

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

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

再改
found = myRng.FindNext(found)

set found = myRng.FindNext(found)

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

我要發表回答

立即登入回答