Micrsoft Excel has stopped working

[Elikki]

Hi,
I am new and this is my first post.
I wrote a VBA code using excel 2010 and every time I run it, I get this error, "Microsoft Excel Has Stopped working". The thing is if I run it from the module, it works fine, but if I click on the button to which a macro is assigned the error popes up. The code is as follows.

Sub CustContact()
 Call FileOpenContact
End Sub

Sub FileOpenContact()

Dim Path            As String
Dim FileName        As String
Dim Wkb             As Workbook
Dim ws              As Worksheet
Dim FolderName      As Variant
Dim Dates           As String


    Application.EnableEvents = False
    Application.ScreenUpdating = False
    Path = "C:\?????\Desktop\?????" 'Change as needed
    FileName = Dir(Path & "\?????????????????.xlsx", vbNormal)
    On Error Resume Next
    Do Until FileName = ""
        Set Wkb = Workbooks.Open(FileName:=Path & "\" & FileName)
        For Each ws In Wkb.Worksheets
            ws.Copy After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count)
        Next ws
        Wkb.Close False
        FileName = Dir()
    On Error Resume Next
    Loop
      Call SelcectCode
End Sub

Sub SelcectCode()

Dim x As Integer, code As String

    Sheets("Codes").Activate
    
    lr = Range("A" & Rows.Count).End(xlUp).Row

        For x = 1 To lr
            If Range("B1").Value = 1 Then
            ElseIf Range("B1").Value = x Then
                code = Cells(x, 1)
                Exit For
            End If
        Next x
        FindContact code
End Sub

Sub FindContact(ByRef code)

Dim x As Integer

    Sheets("Customer").Activate
     ActiveSheet.Name = code
    
    lr = Range("A" & Rows.Count).End(xlUp).Row

        For x = lr To 2 Step -1
            If Cells(x, 3) = code Then
            Else
                Cells(x, 1).EntireRow.Delete
            End If
        Next x
        Columns("B").Delete
        Columns("C:H").Delete
        Columns("Q").Delete
        Columns("R:T").Delete
End Sub

Thanks in advance!

[xladept]

Hi Elikki,

Welcome to the Forum!

I have repaired my 2010 twice since I got it - have you tried repairing your Office 2010?

When we post code we put code tags around it - you need only to highlight your code and click on the #

[FDibbins]

Elikki, welcome to the forum

Your post does not comply with Rule 3 of our Forum RULES. Use code tags around code.

Posting code between [CODE] [/CODE] tags makes your code much easier to read and copy for testing, it also maintains VBA formatting.

Highlight your code and click the # icon at the top of your post window. More information about these and other tags can be found here

I have added them for you - this time

[Elikki]

Thanks! I just posted the code again using the code wrap

[Elikki]

Sub CustContact()
 Call FileOpenContact
End Sub

Sub FileOpenContact()

Dim Path            As String
Dim FileName        As String
Dim Wkb             As Workbook
Dim ws              As Worksheet
Dim FolderName      As Variant
Dim Dates           As String


    Application.EnableEvents = False
    Application.ScreenUpdating = False
    Path = "C:\?????\Desktop\?????" 'Change as needed
    FileName = Dir(Path & "\?????????????????.xlsx", vbNormal)
    On Error Resume Next
    Do Until FileName = ""
        Set Wkb = Workbooks.Open(FileName:=Path & "\" & FileName)
        For Each ws In Wkb.Worksheets
            ws.Copy After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count)
        Next ws
        Wkb.Close False
        FileName = Dir()
    On Error Resume Next
    Loop
      Call SelcectCode
End Sub

Sub SelcectCode()

Dim x As Integer, code As String

    Sheets("Codes").Activate
    
    lr = Range("A" & Rows.Count).End(xlUp).Row

        For x = 1 To lr
            If Range("B1").Value = 1 Then
            ElseIf Range("B1").Value = x Then
                code = Cells(x, 1)
                Exit For
            End If
        Next x
        FindContact code
End Sub

Sub FindContact(ByRef code)

Dim x As Integer

    Sheets("Customer").Activate
     ActiveSheet.Name = code
    
    lr = Range("A" & Rows.Count).End(xlUp).Row

        For x = lr To 2 Step -1
            If Cells(x, 3) = code Then
            Else
                Cells(x, 1).EntireRow.Delete
            End If
        Next x
        Columns("B").Delete
        Columns("C:H").Delete
        Columns("Q").Delete
        Columns("R:T").Delete
End Sub