EXCEL公式自動延伸?

pointchi
個人積分：25分
文章編號：69898681

25分

樓主

2018-08-28 21:35

小弟有一個錄製一個巨集，於D2欄輸入B2*C2，然後點兩下讓公式自動往下延伸，可是A欄筆數不定，如何修改程式碼為自動幫我算到有資料的最後一欄，因為我沒有寫過程式，所以不知要如何修改，是否有前輩可以幫忙修改或提示。

巨集程式碼如下

Sub 巨集1()
'
' 巨集1 巨集
'
'
    ActiveCell.FormulaR1C1 = "=RC[-2]*RC[-1]"
    Range("D2").Select
    Selection.AutoFill Destination:=Range("D2:D7")
    Range("D2:D7").Select
End Sub

EXCEL公式自動延伸?

2018-08-28 21:35 發佈

文章關鍵字 excel 公式

ulean

ulean
個人積分：31分
文章編號：69910594

31分

2樓

2018-08-29 18:34

Public CountX As Long, CountY As Long, row1 As Long

Sub 程式()

    Call CountListData
    '--- 以下為要執行的程式 ---
    Range("D2").Value = "=B2*C2"

    Range("D2").Select
    Selection.Copy
    'MsgBox "總共有 " & CountX & " 筆資料"
    Range("D2:D" & CountY).Select
    ActiveSheet.Paste
    Application.CutCopyMode = False
    Range("D2").Select

End Sub

Sub CountListData()
    Cells(ActiveSheet.Rows.Count, 1).End(xlUp).Select
    '移到資料結尾

    '找到資料結尾的列數
    '註：總列數不一定等於資料總筆數，因為可能會有空白列
    With Selection(1)
        '註：列號為 : .Row  欄號為 : .Column
        CountX = .Row
    End With

    '以 A 欄主為計算不是空白的資料總數
    CountY = Application.WorksheetFunction.CountA(Range("A:A"))

    If CountX = CountY Then
        'MsgBox "資料不含空白列"
        Exit Sub
    Else
        Dim MySselect As Integer
        myselect = MsgBox("警告！資料包含空白列是否刪除", vbYesNo + vbQuestion)

        If myselect = vbYes Then
            Call 刪除空白列
        Else
            MsgBox "您選擇了否，請按確定鍵結束", vbOKOnly + vbExclamation
            End
        End If
    End If

End Sub

Sub 刪除空白列()
    '移到資料結尾
    ActiveCell.SpecialCells(xlLastCell).Select

    '找到資料結尾的列數
    With Selection(1)
        'MsgBox "所選的儲存格位置為 : " & .Address(0, 0) & vbCrLf & vbCrLf & "列號為 : " & .Row & ", 欄號為 : " & .Column
        row1 = .Row
    End With

    For i = row1 To 1 Step -1
        Rows(i & ":" & i).Select
        '如果作用中的儲存格 = 空白就拖出去砍了
        If ActiveCell.Value = Empty Then
            Selection.Delete shift:=xlUp
        Else

        End If
    Next
End Sub