CODEWITHSUNDEEP
vbaexcelduplicatescall
Philip Connell
Philip Connell

Reputation: 651

VBA code not executing properly when called

Hi all I hope you can help. I have a piece of code see below.

What I am trying to achieve is that a user opens up an Excel sheet that contains a command button and instructions. Once the command button is clicked a dialog box opens up which then allows the user to select another excel sheet, once that excel sheet is selected another piece of code (should) fire and duplicates are consolidated and start dates and end dates are amended, and the sheet is left open in its desired state free of duplicates and dates correct.

The piece of code 

Public Sub ConsolidateDupes()

works perfectly when it is run by itself, on the original sheet but when I try to call it with the command button , its is not working correctly. No error appears it just does not remove all the possible duplicates and does not work the dates to the earliest start and latest end date

I have added pictures to make explanation easier Pic 1

Excel sheet with Command Button

Pic 2 the Sheet to be selected in its original state with Duplicates and multiple start and end dates

The selected sheet after code has been run by itslef on that sheet

The selected sheet when it is called when command button is used

As you can hopefully see the Duplicates are left and the dates are not worked to the earliest start date and latest end date

As i said the code works perfectly when run on the sheet by itself but when it is called it leaves duplicates and is not working the start and end dates

Here is my code any help is as always greatly appreciated.

CODE 

Sub Open_Workbook_Dialog()

Dim my_FileName As Variant

    MsgBox "Select Denmark File" '<--| txt box for prompt to pick a file

        my_FileName = Application.GetOpenFilename(FileFilter:="Excel Files,*.xl*;*.xm*") '<--| Opens the file window to allow selection

    If my_FileName <> False Then
    Workbooks.Open Filename:=my_FileName


Call ConsolidateDupes   '<--|Calls the Filter Code and executes

End If


End Sub

Public Sub ConsolidateDupes()
    Dim wks As Worksheet
    Dim lastRow As Long
    Dim r As Long

    Set wks = Sheet1

    lastRow = wks.UsedRange.Rows.Count

    For r = lastRow To 3 Step -1
        ' Identify Duplicate
        If wks.Cells(r, 1) = wks.Cells(r - 1, 1) _
        And wks.Cells(r, 2) = wks.Cells(r - 1, 2) _
        And wks.Cells(r, 3) = wks.Cells(r - 1, 3) _
        And wks.Cells(r, 4) = wks.Cells(r - 1, 4) _
        And wks.Cells(r, 5) = wks.Cells(r - 1, 5) _
        And wks.Cells(r, 6) = wks.Cells(r - 1, 6) _
        And wks.Cells(r, 7) = wks.Cells(r - 1, 7) Then
            ' Update Start Date on Previous Row
            If wks.Cells(r, 8) < wks.Cells(r - 1, 8) Then
                wks.Cells(r - 1, 8) = wks.Cells(r, 8)
            End If
            ' Update End Date on Previous Row
            If wks.Cells(r, 9) > wks.Cells(r - 1, 9) Then
                wks.Cells(r - 1, 9) = wks.Cells(r, 9)
            End If
            ' Delete Duplicate
            Rows(r).Delete
        End If
    Next
End Sub

Upvotes: 0

Views: 570

Answers (1)

Vityata
Vityata

Reputation: 43565

Can you delete this:

    Rows(r).Delete

And write this instead:

    wks.Rows(r).Delete

Edit: Try this: (very dirty solution, but it should work)

Sub Open_Workbook_Dialog()


    Dim strFileName     As string
    dim wkb             as workbook
    Dim wks             As Worksheet
    Dim lastRow         As Long
    Dim r               As Long

    MsgBox "Select Denmark File" '<--| txt box for prompt to pick a file

        strFileName = Application.GetOpenFilename(FileFilter:="Excel Files,*.xl*;*.xm*") '<--| Opens the file window to allow selection

    set wkb = Application.Workbooks.Open(strFileName)
    Set wks = wkb.Sheet1
    lastRow = wks.UsedRange.Rows.Count

    For r = lastRow To 3 Step -1
        ' Identify Duplicate
        If wks.Cells(r, 1) = wks.Cells(r - 1, 1) _
        And wks.Cells(r, 2) = wks.Cells(r - 1, 2) _
        And wks.Cells(r, 3) = wks.Cells(r - 1, 3) _
        And wks.Cells(r, 4) = wks.Cells(r - 1, 4) _
        And wks.Cells(r, 5) = wks.Cells(r - 1, 5) _
        And wks.Cells(r, 6) = wks.Cells(r - 1, 6) _
        And wks.Cells(r, 7) = wks.Cells(r - 1, 7) Then
            ' Update Start Date on Previous Row
            If wks.Cells(r, 8) < wks.Cells(r - 1, 8) Then
                wks.Cells(r - 1, 8) = wks.Cells(r, 8)
            End If
            ' Update End Date on Previous Row
            If wks.Cells(r, 9) > wks.Cells(r - 1, 9) Then
                wks.Cells(r - 1, 9) = wks.Cells(r, 9)
            End If
            ' Delete Duplicate
            Rows(r).Delete
        End If
    Next
End Sub

However, the problem is that it did not work, because you did not pass the my_FileName to the ConsolidateDupes procedure. Thus, the procedure was executing in the file with the button, and it was a bit meaningless there.

Hi so some changes were need to get this to work and the code that works is below I hope it helps a fellow VBA'r out :-) 

   Sub Open_Workbook_Dialog()


    Dim strFileName     As String
    Dim wkb             As Workbook
    Dim wks             As Worksheet
    Dim LastRow         As Long
    Dim r               As Long

    MsgBox "Select Denmark File" '<--| txt box for prompt to pick a file

        strFileName = Application.GetOpenFilename(FileFilter:="Excel Files,*.xl*;*.xm*") '<--| Opens the file window to allow selection

    Set wkb = Application.Workbooks.Open(strFileName)
    Set wks = ActiveWorkbook.Sheets(1)
    LastRow = wks.UsedRange.Rows.Count

    ' Sort the B Column Alphabetically
    With ActiveWorkbook.Sheets(1)

        Dim LastRow2 As Long
        LastRow2 = .Cells(Rows.Count, 1).End(xlUp).Row
        Dim LastCol As Long
        LastCol = .Cells(1, .Columns.Count).End(xlToLeft).Column
        With ActiveWorkbook.Worksheets("Sheet1").Sort
            .SortFields.Clear
            .SortFields.Add Key:=Range(Cells(2, 2), Cells(LastRow, 2)), _
                            SortOn:=xlSortOnValues, _
                            Order:=xlAscending, _
                            DataOption:=xlSortNormal
            .SetRange Range(Cells(2, 1), Cells(LastRow, LastCol))
            .Header = xlNo
            .MatchCase = False
            .Orientation = xlTopToBottom
            .SortMethod = xlPinYin
            .Apply

        End With

    End With

    For r = LastRow To 3 Step -1
        ' Identify Duplicate
        If wks.Cells(r, 1) = wks.Cells(r - 1, 1) _
        And wks.Cells(r, 2) = wks.Cells(r - 1, 2) _
        And wks.Cells(r, 3) = wks.Cells(r - 1, 3) _
        And wks.Cells(r, 4) = wks.Cells(r - 1, 4) _
        And wks.Cells(r, 5) = wks.Cells(r - 1, 5) _
        And wks.Cells(r, 6) = wks.Cells(r - 1, 6) _
        And wks.Cells(r, 7) = wks.Cells(r - 1, 7) Then
           ' Update Start Date on Previous Row
        If CDate(wks.Cells(r, 8)) < CDate(wks.Cells(r - 1, 8)) Then
         wks.Cells(r - 1, 8) = wks.Cells(r, 8)
        End If
        ' Update End Date on Previous Row
        If CDate(wks.Cells(r, 9)) > CDate(wks.Cells(r - 1, 9)) Then
        wks.Cells(r - 1, 9) = wks.Cells(r, 9)
        End If
            ' Delete Duplicate
            Rows(r).Delete
        End If
    Next
End Sub

Upvotes: 1

Related Questions