Shortcut keys not working, ALT+F8+ run does

[sweeneytime]

Hi guys,

I have written the below macro. If I run via the editor or ALT+F8+run it works. I assigned a shortcut key Ctrl+Shift+M. It begins to run the macro, opens the other wb for data for vlookup and then stops, no errors or anything. I have control of excel again. I have highlighted the point below where it stops.

Would anybody have a solution please? Google doesn't have the answer!

Thanks
Alan

Sub GpTbMacro()
    
    'Great Plains Macro
    
    Call Lookup
    Call DelTextRows
    Call NetValue
    Call GpHeader
    
End Sub


Sub Lookup()
'
' Lookup Macro
    Dim Last As Long
    Dim Last2 As Long
    Dim rcell As Range
    Dim oFS As Object
    Dim strFilename As String
    Dim varAnswer As String
    Dim Data As Workbook
    
    Application.ScreenUpdating = False
    
    Set Data = ActiveWorkbook
    
    Last = Range("A" & Rows.Count).End(xlUp).Row
    Last2 = Range("C" & Rows.Count).End(xlUp).Row
     
    strFilename = "O:\ORC Finance\Orygen 10-11\Alan\accounts.xlsm"
    'This creates an instance of the MS Scripting Runtime FileSystemObject class
    Set oFS = CreateObject("Scripting.FileSystemObject")

    ' MsgBox("Are Both Parapets the Same?", vbYesNo, "PARAPETS")
    
    MsgBox strFilename & " was last modified on " & oFS.GetFile(strFilename).Datelastmodified
    
    Set oFS = Nothing

    If MsgBox("Are you sure you want to continue?", vbQuestion + vbYesNo, "Exit") = vbNo Then
    Exit Sub
    Else
        'what else is there to do?
    End If
    'Open chart of accounts WB
    ChDir "O:\ORC Finance\Orygen 10-11\Alan"
    Workbooks.Open Filename:="O:\ORC Finance\Orygen 10-11\Alan\accounts.xlsm", _
        Notify:=False, IgnoreReadOnlyRecommended:=True

Stops Around here - Original worksheet does not re-activate.

[COLOR=Red] [COLOR=Black]Data.Activate[/COLOR][/COLOR] 
    

    Range("C:C").Insert
   
    Range("C7").Select
    ActiveCell.FormulaR1C1 = "=VLOOKUP(RC[-1],[accounts.xlsm]Sheet1!C[-2]:C[-1],2,FALSE)"
    ActiveCell.Offset(1, 0).Range("A1").Select
    
    Range("C7:C" & Last - 1).FillDown
    
    ActiveCell.Columns("A:A").EntireColumn.Select
    Selection.SpecialCells(xlCellTypeFormulas, 16).Select
    Selection.ClearContents
    
    Range("C1") = "Account Number"
    
    ActiveCell.Columns("A:A").EntireColumn.Select
    Selection.SpecialCells(xlCellTypeBlanks).Select
    Selection.FormulaR1C1 = "=R[-1]C"
    Range("A1").Select
    
    Range("C2:C6").ClearContents
    
  
    Range("C:C").Select
    Range("C:C").Copy
    Range("C:C").Select
    Selection.PasteSpecial Paste:=xlPasteValues, _
    Operation:=xlNone, _
    SkipBlanks:=False, _
    Transpose:=False
    Application.CutCopyMode = False
    Range("A1").Select
    
    Windows("accounts.xlsm").Close False
    
    Application.ScreenUpdating = True
    
    
End Sub

Sub DelRows()
    
    Dim c As Range
    Dim lngLastRow As Long
    
    Last = Range("A" & Rows.Count).End(xlUp).Row
    
    Application.ScreenUpdating = False
    
    For Each c In Range("A1:A" & Last)
        If IsDate(c.Value) = False Then
            c.EntireRow.Delete
        End If
    Next
    
    Application.ScreenUpdating = True
    
    MsgBox Prompt:="All Non Account rows have been deleted", Title:="Orygen Finance"
    
End Sub
Sub DelTextRows()
 
    Dim Last As Long
    
    Application.ScreenUpdating = False
    Last = Range("A" & Rows.Count).End(xlUp).Row

    Dim i
 
    FinalRow = Cells(Rows.Count, 1).End(xlUp).Row
 
    For i = FinalRow To 1 Step -1
 
        If IsDate(Cells(i, 1)) = False Then
 
            Cells(i, 1).EntireRow.Delete
 
        End If
 
    Next i
    Application.ScreenUpdating = True
    
    
End Sub

Sub GetDateLastModified()

    Dim oFS As Object
    Dim strFilename As String
    Dim varAnswer As String
    
    'Put your filename here
    strFilename = "O:\ORC Finance\Orygen 10-11\Alan\accounts.xlsm"


    'This creates an instance of the MS Scripting Runtime FileSystemObject class
    Set oFS = CreateObject("Scripting.FileSystemObject")
    
    
     
    ' MsgBox("Are Both Parapets the Same?", vbYesNo, "PARAPETS")
    
    MsgBox strFilename & " was last modified on " & oFS.GetFile(strFilename).Datelastmodified
    
    

    Set oFS = Nothing

    If MsgBox("Are you sure you want to continue?", vbQuestion + vbYesNo, "Exit") = vbNo Then
    Exit Sub
    Else
        'what else is there to do?
    End If


End Sub
Sub NetValue()
    
    
    Dim Last As Long
    Application.ScreenUpdating = False
    
    Last = Range("A" & Rows.Count).End(xlUp).Row
    
    
    Range("K1").Select
    ActiveCell.FormulaR1C1 = "=RC[-1]-RC[-2]"
    Range("k1:k" & Last).Select
    Range("k1:k" & Last).FillDown
    'AutoFit
    Range("k:K").Select
    Rows.Select
    Selection.Columns.AutoFit
       
    Range("A1").Select
    
    
    
End Sub

Sub GpHeader()
    
    Range("A1").EntireRow.Insert
    Range("A1") = "Date"
    Range("B1") = "JNL"
    Range("C1") = "Account"
    Range("D1") = "Identifier"
    
    Range("E1") = "Trans Type"
    Range("F1") = "Doc Name"
    Range("G1") = "Vendor Name"
    Range("H1") = ""
    Range("I1") = "Debit"
    Range("J1") = "Credit"
    Range("K1") = "Net"
    
    MsgBox Prompt:="Job Completed", Title:="Orygen Finance"
    
End Sub

 

[venkat1926]

reg control shift M there are some observations

http://social.msdn.microsoft.com/Forums/en-GB/exceldev/thread/b05d7b95-11dd-49cf-8b01-8f2a9804515e

 

[sweeneytime]

Thanks for that!