iT邦幫忙

0

VBA依條件複製公式跨列貼上公式後再貼上為值

  • 分享至 

  • xImage

問題:

請問如何使用VBA達成以下條件:

  1. 設計一個按鈕,按下去後自動複製D4:M4公式,參照P欄為1時,向下貼上公式至D5:M72,但輔助欄為空格該列則跳過不貼上公式。
  2. 參照P欄為1時,向下貼上公式至D5:M72後,再將該列複製貼上為值。

每次按鈕都會重複以上2個動作,以上求解~~~~~~

測試檔https://drive.google.com/file/d/1UPfgL3YAoR-KR898M-bn4U8mNCd6ii62/view?usp=sharing

看更多先前的討論...收起先前的討論...
補充一下,步驟1完成後需先運算完成,才能再執行步驟2,避免公式未運算完成就直接被貼上為值了,謝謝~~~~
小魚 iT邦大師 1 級 ‧ 2021-05-13 08:46:02 檢舉
要不要自己先做做看.
小魚大師~~~ 其實~~~我就是上網找不到解法跟自己不知道怎麼做才會發問的,不然我通常是上網爬文幾乎就可以找到方法,真的是非常抱歉~~~~~
先用錄製巨集,把CODE生出來。
P大 是指醬嗎?

Range("D4:M4").Copy
Range("D5:D13,D15:D21,D24:D30,D32:D34,D36:D44,D46:D47,D49:D54,D56:D60,D62:D67,D69:D73").PasteSpecial Paste:=xlPasteFormulas
各位大大~~我目前測試到以下階段,但仍無法判斷P欄為1時才貼上,也就是目前無論P欄是否為1都會持續往下貼上公式,是否可以請教該如何修改呢?非常感謝~~~

Sub test()
Range("D4:M4").Copy

Set RngD = Range("D5:D73")
Set RngP = Range("P5:P73")

For Each x In RngP
For Each y In RngD
If x.Value = 1 Then
Cells(y.Row, y.Column).PasteSpecial Paste:=xlPasteFormulas
End If
Next
Next
End Sub
圖片
  直播研討會
圖片
{{ item.channelVendor }} {{ item.webinarstarted }} |
{{ formatDate(item.duration) }}
直播中

1 個回答

0
海綿寶寶
iT邦大神 1 級 ‧ 2021-05-17 11:23:30
最佳解答

我看原始資料有幾個不太合理的地方
使用以下 VBA 之前要先備份資料比較保險

Sub MainLoop()
    '1.複製 D4:M4
    CopyFormula (4)
    
    '2.貼上 D5:M72
    For nR = 5 To 72
        If Range("P" & nR) = 1 Then
            PasteFormula (nR)
        End If
    Next
    
    '3.D5:M72 公式貼上為值
    For nR = 5 To 72
        If Range("P" & nR) = 1 Then
            FormulaToValue (nR)
        End If
    Next
End Sub
'複製一列的公式
Sub CopyFormula(ByVal pRow)
    Range("D" & pRow & ":M" & pRow).Select
    Selection.Copy
End Sub
'貼上一列的公式
Sub PasteFormula(ByVal pRow)
    Range("D" & pRow).Select
    Selection.PasteSpecial Paste:=xlPasteFormulas, Operation:=xlNone, _
        SkipBlanks:=False, Transpose:=False
End Sub
'複製一列的公式並在同位置貼上為值
Sub FormulaToValue(ByVal pRow)
    Range("D" & pRow & ":M" & pRow).Select
    Application.CutCopyMode = False
    Selection.Copy
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
End Sub

海大真是太感謝你了,測試成功問題已解決,再次感謝你的大力幫忙了~~~~

我要發表回答

立即登入回答