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
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