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

vba excel vba

msmplayv121068 2021-05-12 18:52:10 ‧ 7982 瀏覽

分享至

問題：

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

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

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

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

看更多先前的討論...收起先前的討論...

msmplayv121068 iT邦新手 4 級 ‧ 2021-05-12 19:23:25 檢舉

補充一下，步驟1完成後需先運算完成，才能再執行步驟2，避免公式未運算完成就直接被貼上為值了，謝謝~~~~

小魚 iT邦大師 1 級 ‧ 2021-05-13 08:46:02 檢舉

要不要自己先做做看.

msmplayv121068 iT邦新手 4 級 ‧ 2021-05-13 08:56:10 檢舉

小魚大師~~~ 其實~~~我就是上網找不到解法跟自己不知道怎麼做才會發問的，不然我通常是上網爬文幾乎就可以找到方法，真的是非常抱歉~~~~~

paicheng0111 iT邦大師 5 級 ‧ 2021-05-13 12:26:45 檢舉

先用錄製巨集，把CODE生出來。

msmplayv121068 iT邦新手 4 級 ‧ 2021-05-13 13:50:04 檢舉

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

msmplayv121068 iT邦新手 4 級 ‧ 2021-05-17 10:02:19 檢舉

各位大大~~我目前測試到以下階段，但仍無法判斷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 }} |

直播中

1 個回答

海綿寶寶

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