James Snyder
Well-known Member
- Joined
- Jan 11, 2013
- Messages
- 618
I am having two problems dealing with the handling of duplicates in VBA. One is the inclusion of an extraneous row (Row1) when filtering and the other is the failure of CountIf > 1 to return duplicates. Since both are in the same block of code, I am combining my questions.
I am using VBA in Excel 2010. The code is being run from a controller spreadsheet that has paths to the files in A1:A7. I am using functions with ByRef parameters to pass worksheet and workbook refs. All returns are error checking or paths only.
Defines and calling code:
I included a function above that removes section headings and blank space since it is in the path. Below is the function for recording and removing duplicates:
Filtered range:
<tbody>
</tbody>
The first row (filtered by second column) should not be in this filtered set. I get three areas returned from counting areas, and that one is the mystery. (I need to download that spreadsheet display app). Anything pop out as something I am doing incorrectly?
I am using VBA in Excel 2010. The code is being run from a controller spreadsheet that has paths to the files in A1:A7. I am using functions with ByRef parameters to pass worksheet and workbook refs. All returns are error checking or paths only.
Defines and calling code:
Code:
Public Sub Main()
' Declarations and Definitions
' EXCEL
Dim obstWkBook As Workbook ' Input XLSX file for Obstructed
Dim obstWkSheet As Worksheet ' Input XLSX file for Obstructed
Dim workOWkBook As Workbook ' Input XLSX file for WorkOrders
Dim workOWkSheet As Worksheet ' Input XLSX file for WorkOrders
Dim ftpWkBook As Workbook ' Input XLSX file for FTP
Dim ftpWkSheet As Worksheet ' Input XLSX file for FTP
Dim filterColumn As Long ' Input XLSX file for duplicate checking
Dim endColumn As String ' Input XLSX file for duplicate checking
Dim InspString As String ' Input parameter for duplicate checking
Dim cGasString As String ' Input parameter for duplicate checking
Dim movedString As String ' Input parameter for duplicate checking
Dim obstString As String ' Input parameter for duplicate checking
Dim srcString As String ' Input parameter for duplicate checking
Dim obstInFile As String ' Source spreadsheet for Obstructed
Dim workOInFile As String ' Source spreadsheet for work orders
Dim ftpInFile As String ' Source spreadsheet for FTP
Dim obstOutBook As Workbook ' Obstructed/Moved/Not On Premises workbook
Dim obstOutSheet As Worksheet ' Obstructed/Moved/Not On Premises sheet
Dim obstOutFile As String ' Obstructed/Moved/Not On Premises file name
Dim ftpOutBook As Workbook ' Output reconciliation workbook
Dim ftpOutSheet As Worksheet ' Output reconciliation spreadsheet
Dim ftpOutFile As String ' Output reconciliation file name
' FILE
Dim fileName As String ' Reuseable parameter
Dim filePath As String ' Destination for files
Dim extension As String ' File extension passed to create each file
Dim exceptFile As String ' Exceptions file for records not sent
Dim ftpTextFile As String ' Output text file for FTP to client
' EXCEPTIONS ARRAY
Dim exceptArray() As String ' Array of exceptions removed from output
Dim dupePSID As String ' Holds the PSID string of each record removed
' Dim exceptError As String ' Holds the error string for exceptions report
' Dim arrRow As Long ' Row index into array
' Dim arrCount As Long ' Number of records in array for looping
' Dim currentRow As Long ' Reference to row being worked, row counter
' PROCESS
Static sendDate As String ' File date used for all created files per run
Dim funcReturn As String ' Returns error message for function failures
Dim failReturn As String ' Returns path of Exceptions file or ""
Dim errSource As String ' Reuseable parameter string for error source
Dim errString As String ' Reuseable parameter string for error messages
Dim cellRef As Range ' Reuseable parameter for sheet data
...snip...
' Set the timestamp for file construction
sendDate = FileDate(sendDate)
...snip...
' Get the WorkOrder file path
fileName = "WorkOrders.xlsx"
Set cellRef = Range("$A$3")
workOInFile = RetrieveFilePath(cellRef, fileName, sendDate)
If workOInFile = "" Then
errString = "WorkOrder.xlsx: Unable to find file path."
failReturn = ProblemReport(errString, sendDate)
Err.Clear
GoTo ExitPoint
Else
' Open the Obstructed .xlsx and correct headers
funcReturn = PrepareWorkOrdersFile(workOInFile, workOWkBook, workOWkSheet, sendDate)
If funcReturn <> "Success" Then
GoTo ExitPoint
End If
End If
' Check for Columbia Gas, Meter Moved Outside, Obstructed duplicates
filterColumn = 2
endColumn = "E"
srcString = Space(18 - Len("WorkOrders"))
srcString = "WorkOrders" & srcString
cGasString = "Columbia Gas Completed"
movedString = "Meter Moved Outside"
obstString = "Obstructed Meter"
funcReturn = PSIDDupeCheck(workOWkBook, workOWkSheet, filterColumn, exceptArray, _
sendDate, srcString, endColumn, cGasString, movedString, obstString)
If funcReturn <> "Success" Then
errString = "DupeCheck fail: Error while checking for CG/Moved/Obstructed duplicates"
failReturn = ProblemReport(errString, sendDate)
Err.Clear
GoTo ExitPoint
End IfI included a function above that removes section headings and blank space since it is in the path. Below is the function for recording and removing duplicates:
Code:
Private Function PrepareWorkOrdersFile(ByRef workOInFile As String, _
ByRef workOWkBook As Workbook, _
ByRef workOWkSheet As Worksheet, _
ByRef sendDate As String) As String
Dim errString As String
Dim failReturn As String
Dim lastRow As Long
Dim i As Long ' Loop counter
Application.ScreenUpdating = True
Workbooks.Open fileName:=workOInFile
Set workOWkBook = ActiveWorkbook
If Not workOWkBook Is Nothing Then
Set workOWkSheet = workOWkBook.Sheets(1)
If Not workOWkSheet Is Nothing Then
workOWkSheet.Range("B1") = "PSID"
workOWkSheet.Range("C1") = "Item No"
lastRow = workOWkSheet.Range("B65535").End(xlUp).Row
For i = lastRow To 1 Step -1
If Not IsEmpty(workOWkSheet.Range("A" & i).Value) Then ' Delete group headings
workOWkSheet.Range("A" & i).EntireRow.Delete
End If
If IsEmpty(workOWkSheet.Range("B" & i)) Then ' Delete empty rows
workOWkSheet.Range("B" & i).EntireRow.Delete
End If
Next i
workOWkSheet.Range("A1").EntireColumn.Delete
Application.DisplayAlerts = False ' Suppress "SaveAs" dialog box
Application.EnableEvents = False ' Suppress BeforeSave event
workOWkBook.Save
Application.EnableEvents = True
Application.DisplayAlerts = True
PrepareWorkOrdersFile = "Success"
Else
errString = "WorkOrders: Failed to open worksheet to fix headers"
failReturn = ProblemReport(errString, sendDate)
Err.Clear
PrepareWorkOrdersFile = errString
End If
Else
errString = "WorkOrders: Failed to open workbook to fix headers"
failReturn = ProblemReport(errString, sendDate)
Err.Clear
PrepareWorkOrdersFile = errString
End If
Application.ScreenUpdating = False
End Function
Private Function CountFilteredRows(ByRef filtRange As Range, _
ByVal filtAreas As Long, _
ByRef sendDate As String) As Long
Dim i As Long
Dim count As Long
With filtRange
For i = 2 To filtAreas ' Do not count the headers (area1)
count = count + .Areas(i).Rows.count ' Assign last row in filtered PSIDs
Next i
End With
CountFilteredRows = count
End Function
Private Function PSIDDupeCheck(ByRef wkBook As Workbook, _
ByRef wkSheet As Worksheet, _
ByVal wkColumn As Long, _
ByRef exceptArray() As String, _
ByRef sendDate As String, _
ByVal errorSrc As String, _
Optional ByVal param1 As String, _
Optional ByVal param2 As String, _
Optional ByVal param3 As String, _
Optional ByVal param4 As String) As String
Dim origRange As Range
Dim rowMax As Long
Dim filteredRange As Range
Dim filteredColumn As Long
Dim filterMax As Long
Dim areaCount As Long
Dim dupeRow As Long
Dim i As Long, j As Long, k As Long
Dim failReturn As String
Dim errString As String
Dim y As Boolean
Dim z As String
If Not wkBook Is Nothing Then
Set wkSheet = wkBook.Sheets(1)
If Not wkSheet Is Nothing Then
rowMax = wkSheet.Range("A65535").End(xlUp).Row ' Assign last row
wkSheet.Range("A1:E" & rowMax).Sort _
key1:=wkSheet.Range("B1"), _
key2:=wkSheet.Range("A1")
With wkSheet
.AutoFilterMode = False
Set origRange = .Range("A1:" & param1 & rowMax)
With origRange
' Set AutoFilter to screen out non-compared objects
.AutoFilter Field:=wkColumn, Criteria1:=Array( _
param2, _
param3, _
param4), _
Operator:=xlFilterValues
Set filteredRange = .SpecialCells(xlCellTypeVisible)
With filteredRange
[B][COLOR=#008000]areaCount = .Areas.count[/COLOR][/B] ' 1 for headers, 1 for CG, 1 for Moved/Obstructed
Debug.Print .Address(0, 0, , True)
filterMax = CountFilteredRows(filteredRange, areaCount, sendDate)
For i = filterMax To 2 Step -1 ' Delete from bottom to avoid changing row numbers
' Look at the current PSID for any duplicate PSIDs
If [B][COLOR=#b22222]Application.WorksheetFunction.CountIf(filteredRange.Range("A1:A" & filterMax), _
filteredRange.Range("A" & i).Value > 1)[/COLOR][/B] Then
dupeRow = dupeRow + 1
Debug.Print "Dupe" & i & " " & filteredRange.Range("A" & i).Value
ReDim Preserve exceptArray(dupeRow - 1) ' Adjust array size up by one row
exceptArray(dupeRow - 1) = filteredRange.Range("A" & i).Value ' Record in array
' Once entered into array, write to Exceptions and delete
errString = exceptArray(dupeRow - 1) & " Duplicate PSID record"
failReturn = ProblemReport(errString, sendDate)
filteredRange.Range("A" & i).EntireRow.Delete ' Delete the dupeValue with the count of 2
End If
Next i
End With ' filteredRange
End With ' origRange
.ShowAllData
End With ' wkSheet
Application.DisplayAlerts = False ' Suppress "SaveAs" dialog box
wkBook.Save
Application.DisplayAlerts = True
Application.EnableEvents = True
PSIDDupeCheck = "Success"
Else
errString = errorSrc & "Failed to open worksheet get dupes"
failReturn = ProblemReport(errString, sendDate)
Err.Clear
PSIDDupeCheck = errString
End If
Else
errString = errorSrc & "Failed to open workbook get dupes"
failReturn = ProblemReport(errString, sendDate)
Err.Clear
PSIDDupeCheck = errString
End If
wkSheet.AutoFilterMode = False
End FunctionFiltered range:
<tbody> </tbody> |
<tbody>
</tbody>
The first row (filtered by second column) should not be in this filtered set. I get three areas returned from counting areas, and that one is the mystery. (I need to download that spreadsheet display app). Anything pop out as something I am doing incorrectly?
