0

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
Improve this question

1 Answer 1

Reset to default
1

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
Improve this answer
Sign up to request clarification or add additional context in comments.

18 Comments

Thank you for taking the time to respond Vityata. I made the change but no luck. It doesn't work unfortunately.
Save the sheet, close it, open it and try again. It should work.
Open was written with M. Try again :)
Oh you have helped greatly i hope to pay it all forward some day. I have removed the pics thanks for the heads up. sound advice.
Good to know - once you become more experienced you may take a look again at the code and remove the ActiveWorkbook part and set the workbook directly. Activeworkbook, activesheet, activecell, etc. is considered bad practise in VBA. But as far as it works, it is ok.
|

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service and acknowledge you have read our privacy policy.

Start asking to get answers

Find the answer to your question by asking.

Ask question

Explore related questions

See similar questions with these tags.