Question

    Private Sub Worksheet_Change(ByVal Target As Range)
    If Not Intersect(Target, Range("E2:E50")) Is Nothing Then
    Call sbDriverCopy
    Call sbDriverRotation
    End If
    End Sub

    Sub sbDriverRotation()
    Dim strDataRange, strkeyRange As String
    strDataRange = "J1:N50"
    strkeyRange = "L2:L50"
    With Sheets("Sheet1").Sort
    .SortFields.Clear
    .SortFields.Add _
    Key:=Range(strkeyRange), _
    SortOn:=xlSortOnValues, _
    Order:=xlDescending, _
    DataOption:=xlSortNormal
    .SetRange Range(strDataRange)
    .Header = xlYes
    .MatchCase = False
    .Orientation = xlTopToBottom
    .SortMethod = xlPinYin
    .Apply
    End With
    End Sub


    Sub sbDriverCopy()
    Range("D1:H50").Copy
    Range("J1").Select
    ActiveSheet.PasteSpecial xlPasteValuesAndNumberFormats
    Application.CutCopyMode = False
    End Sub

E列是在B-A列或TO-A列上计算的，当这些计算的值转到E列时，我希望触发我的marcos。我尝试了几种不同的方法，但不能让马克开火。

我认为我需要将我的marco合并为一个？

    Private Sub Worksheet_Calculate()
    If Range("E2").Value <> PrevVal Then
    MsgBox "Value Changed"
    PrevVal = Range("E2").Value
    End If
    End Sub

所以我可以通过更改单元格（E2）来解决这个问题，但是无法弄清楚如何让它在一个范围内工作（E2：E50）

Answer 1

    Private Sub Worksheet_Calculate()
    'Updateby Extendoffice
        Dim Xrg As Range
        Set Xrg = Range("E2:E50")
        If Not Intersect(Xrg, Range("E2:E50")) Is Nothing Then
            sbDriverCopy
            sbDriverRotation
        End If
        Set Xrg = Nothing
    End Sub

    Sub sbClearDriverRotation()
        Range("J1:N50").ClearContents
    End Sub

    Sub sbDriverCopy()
        Range("D1:H50").Copy
        Range("J1").Select
        ActiveSheet.PasteSpecial xlPasteValuesAndNumberFormats
        Application.CutCopyMode = False
    End Sub

    Sub sbDriverRotation()
        Dim strDataRange, strkeyRange As String
            strDataRange = "J1:N50"
            strkeyRange = "L2:L50"
            With Sheets("Sheet1").Sort
                .SortFields.Clear
                .SortFields.Add _
                    Key:=Range(strkeyRange), _
                    SortOn:=xlSortOnValues, _
                    Order:=xlDescending, _
                    DataOption:=xlSortNormal
                .SetRange Range(strDataRange)
                .Header = xlYes
                .MatchCase = False
                .Orientation = xlTopToBottom
                .SortMethod = xlPinYin
                .Apply
            End With
    End Sub

Answer 2

以下是单元格值更改时如何发送电子邮件的一个很好的示例。

Sub Mail_small_Text_Outlook()
'For Tips see: http://www.rondebruin.nl/win/winmail/Outlook/tips.htm
'Working in Excel 2000-2016
    Dim OutApp As Object
    Dim OutMail As Object
    Dim strbody As String

    Set OutApp = CreateObject("Outlook.Application")
    Set OutMail = OutApp.CreateItem(0)

    strbody = "Hi there" & vbNewLine & vbNewLine & _
              "Cell A1 is changed" & vbNewLine & _
              "This is line 2" & vbNewLine & _
              "This is line 3" & vbNewLine & _
              "This is line 4"

    On Error Resume Next
    With OutMail
        .To = "ron@debruin.nl"
        .CC = ""
        .BCC = ""
        .Subject = "This is the Subject line"
        .Body = strbody
        'You can add a file like this
        '.Attachments.Add ("C:\test.txt")
        .Display   'or use .Send
    End With
    On Error GoTo 0

    Set OutMail = Nothing
    Set OutApp = Nothing
End Sub

https://www.rondebruin.nl/win/s1/outlook/bmail9.htm

VBA和Excel我需要在单元格更改上运行宏

2 个答案: