简体   繁体   中英

VBA and Excel I need to run a macro on cell change

    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

The E column is calculated on either the BA column or TO-A column and on that change when the values of those calculations go to the E column I want to fire my marcos. I tried several different ways but cant get the marco to fire.

Than I am thinking i need to combine my marco into one?

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

So I can get this to fire on a change in cell(E2) but cant figure out how to get it to work for a range(E2:E50)

    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

Here is a great example of how to send an email when a cell value changes.

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

The technical post webpages of this site follow the CC BY-SA 4.0 protocol. If you need to reprint, please indicate the site URL or the original address.Any question please contact:yoyou2525@163.com.

 
粤ICP备18138465号  © 2020-2024 STACKOOM.COM