Solved: Very Custom Program

[mribbans]

I'm wondering if anyone has any ideas for a program that does the following:

In Col C there is a list of about 16000 numbers, most of which being the same (lets say it is 1563 for example). Col A consists of reference numbers in pairs so it's set up like this:

Col A Col C
5466 1563
5466 1563
5484 1563
5484 1559
6583 1563
6583 1563

1. Search Col C for any number than 1563
2. Compare the coresponding value of the immediate upper and lower cells in Col A
3. Select matching Col A reference numbers
4. Copy both rows (the rows with the same Col A value) to Sheet 2

My desired end result would be:

Sheet 1
Col A Col C
5466 1563
5466 1563
6583 1563
6583 1563

Sheet 2
Col A Col C
5484 1563
5484 1559


Any help would be great. If you need any other details, let me know. Thanks in advance!

[Bob Phillips]

Public Sub ProcessData()
Const TestCol1 As String = "A"
Const TestCol2 As String = "C"
Dim i As Long
Dim LastRow As Long
Dim NextRow As Long

With Application

.ScreenUpdating = False
.Calculation = xlCalculationManual
End With

With Worksheets("Sheet1")

LastRow = .Cells(.Rows.Count, TestCol1).End(xlUp).Row
NextRow = 1
For i = 2 To LastRow

If .Cells(i, TestCol2).Value <> 1563 Then

If .Cells(i, TestCol1).Value = .Cells(i - 1, TestCol1).Value Then

.Rows(i - 1).Resize(2).Copy Worksheets("Sheet2").Cells(NextRow, "A")
NextRow = NextRow + 2
End If
End If
Next i
End With

With Application

.Calculation = xlCalculationAutomatic
.ScreenUpdating = True
End With

End Sub

[Oorang]

I had already put this together prior to XL Xid post, but then I went to lunch and forgot to actually post it. Since I already wrote it, I thought I would go ahead and put it up:
'-------------------------------------------------------------------------------
' Module : CustomSearch
' Author : Aaron Bush
' Date : 06/11/2008
' Purpose : Contains custom search procedures.
' References : Microsoft Excel 11.0
' Dependencies : None
'-------------------------------------------------------------------------------

Option Explicit
'Option Private Module
Option Compare Binary
Option Base 0

'Setting this to True will turn off all error handling:
#Const m_blnErrorHandlersOff_c = False

Public Type OffsetValues
Row As Long
Column As Long
End Type

Public Sub Output1563Exceptions()
Dim udtChecks(1) As OffsetValues
'Create cross check array:
udtChecks(0).Row = -1
udtChecks(0).Column = -2
udtChecks(1).Row = 1
udtChecks(1).Column = -2
'Begin search:
If ProximitySearch(3, "<>1563", udtChecks) Then
MsgBox "Operation Completed.", , "Epic! :)"
Else
MsgBox "Operation has encounter an error.", , "Oh Noes! :("
End If
End Sub


Private Function ProximitySearch(ByVal searchColumn As Long, _
ByVal searchCriteria As String, _
ByRef crossChecks() As OffsetValues, _
Optional ByVal searchFuzzy As Boolean = True, _
Optional ByVal hasHeader As Boolean = True _
) As Boolean

'---------------------------------------------------------------------------
' Procedure : ProximitySearch
' Author : Aaron Bush
' Date : 06/11/2008
' Purpose : Provides a modular interface to allow for configurable
' proximity searches:
' Input(s) : searchColumn - The column that you want searched to see if
' main criteria are met.
' searchCriteria - The criteria that must be met before a
' proximity check is performed.
' crossChecks - An array of offset references to cross check
' against a value meeting the search criteria.
' searchFuzzy - Optional. Default is True. When True
' comparisons are *not* case sensitive and
' leading/trailing spaces are ignored.
' hasHeader - Optional. Default is True. If true the first
' cell in the used range of the column will not
' be included in the search and the entire row
' will be copied over to the output sheet.
' Output(s) : True if completed, false if error occurred.
' Remarks : This procedure will check every cell in the specified column
' Revisions : Aaron Bush 06/11/2008 Added percent complete to status
' bar.
'---------------------------------------------------------------------------

'Used to format output sheet:
Const strSheetName_c As String = "Output"

'Used in custom errors:
Const strProcedureName_c As String = "ProximitySearch"
Const lngErrInvldRngNum_c As Long = vbObjectError + 800
Const strErrInvldRngMsg_c As String = "The range you have specified to " & _
"search does not appear to " & _
"contain any cells."
'Misc Constants:
Const lngZero_c As Long = 0
Const lngOne_c As Long = 1
Const lngThree_c As Long = 3
'Status Display Format:
Const strFormat_c As String = """Working... ""0.0%"

Dim wsSrch As Excel.Worksheet
Dim wsOtpt As Excel.Worksheet
Dim rngSrch As Excel.Range
Dim rngCll As Excel.Range
Dim rngChk As Excel.Range
Dim rngCpy As Excel.Range
Dim lngOrgSINW As Long
Dim blnCmplt As Boolean
Dim blnDoCopy As Boolean
Dim strCllVal As String
Dim strChkVal As String
Dim dblLstStatus As Double
Dim dblStatus As Double
'Used for looping though cross-check array:
Dim lngLwrBnd As Long
Dim lngUprBnd As Long
Dim lngIndx As Long
Dim lngCntr As Long
Dim lngClls As Long
'Conditionally Invoke Error Handler:
#If Not m_blnErrorHandlersOff_c Then
On Error GoTo Err_Hnd
DisableInterface
#End If

'Get input worksheet:
Set wsSrch = Excel.ActiveSheet

'Create Output Worksheet:
lngOrgSINW = Excel.Application.SheetsInNewWorkbook 'Record original setting.
Excel.Application.SheetsInNewWorkbook = lngOne_c 'Only need 1 sheet in wb.
'Create new workbook, and grab worksheet one:
Set wsOtpt = Excel.Workbooks.Add.Worksheets(lngOne_c)
Excel.Application.SheetsInNewWorkbook = lngOrgSINW 'Restore org-setting.
'Give output worksheet a name:
wsOtpt.Name = strSheetName_c
'Give output worksheet a color:
wsOtpt.Tab.Color = RGB(0, 0, 83)

'Set search range from parameter given:
Set rngSrch = wsSrch.Columns(searchColumn)
'Limit srch rng to used range:
Set rngSrch = Excel.Intersect(rngSrch, wsSrch.UsedRange)
'Optionally remove header row. This method should also work with 2007 as it
'does not assume the 65536 limit, but is untested:
If hasHeader Then
Set rngSrch = Excel.Intersect(rngSrch, _
wsSrch.Rows(wsSrch.UsedRange.Row + lngOne_c _
& ":" & wsOtpt.Rows.Count))
'Copy over header row. This method does not assume the row one will be
'the top row of the worksheet:
wsSrch.Rows(wsSrch.UsedRange.Row).Copy wsOtpt.Rows(lngOne_c)
End If
'Catch bad search argument:
If rngSrch Is Nothing Then
Err.Raise lngErrInvldRngNum_c, strProcedureName_c, strErrInvldRngMsg_c
End If
'Record cell count for later use:
lngClls = rngSrch.Count


'Get parameters for cross check values:
lngLwrBnd = LBound(crossChecks)
lngUprBnd = UBound(crossChecks)

'Begin searching cells in search range:
For Each rngCll In rngSrch.Cells
'Increment cell counter:
lngCntr = lngCntr + lngOne_c
'Display Status:
dblStatus = Round(lngCntr / lngClls, lngThree_c)
If dblStatus > dblLstStatus Then
'Only writing to status bar when the value is change reduces status
'bar flicker.
dblLstStatus = dblStatus
Excel.Application.StatusBar = Format$(dblStatus, strFormat_c)
End If
'Record cell value:
strCllVal = rngCll.value
'If search fuzzy is enabled then trim cell to remove leading/trailing
'spaces and make lower case to allow for a non case-sensitive
'comparison.
If searchFuzzy Then
strCllVal = LCase$(Trim$(strCllVal))
End If
'See if cell meets search criteria:
If SafeEval(strCllVal & searchCriteria) Then
'If cell does meet search criteria, perform cross checks:
Set rngCpy = wsSrch.Rows(rngCll.Row) 'Preset copy range.
'Loop through cross check array:
For lngIndx = lngLwrBnd To lngUprBnd
'Get cross check cell's range object:
Set rngChk = rngCll.Offset(crossChecks(lngIndx).Row, _
crossChecks(lngIndx).Column)
'Get value of cross check cell:
strChkVal = rngChk.value
'Get offset value of search cell to match with cross-check
'value:
strCllVal = _
rngCll.Offset(lngZero_c, crossChecks(lngIndx).Column).value
'If search fuzzy is enabled then trim cell to remove leading/trailing
'spaces and make lower case to allow for a non case-sensitive
'comparison.
If searchFuzzy Then
strCllVal = LCase$(Trim$(strCllVal))
strChkVal = LCase$(Trim$(strChkVal))
End If
'If cell that met search criteria meets then add to the copy
'range:
If strCllVal <> strChkVal Then
Set rngCpy = Excel.Union(rngCpy, wsSrch.Rows(rngChk.Row))
'Flag to copy when range is done being built:
blnDoCopy = True
End If
Next
'If flagged to copy, then copy:
If blnDoCopy Then
rngCpy.Copy wsOtpt.UsedRange.Rows(wsOtpt.UsedRange.Rows.Count + lngOne_c)
blnDoCopy = False 'Reset flag
End If
End If
Next
'Flag Procedure as complete:
blnCmplt = True

'******* Exit Procedure *******
Exit_Proc:
'Supress Error Handling to Prevent Error-Loops:
On Error Resume Next
'Verify SheetsInNewWorkbook has been restored:
If lngOrgSINW Then
If lngOrgSINW <> Excel.Application.SheetsInNewWorkbook Then
Excel.Application.SheetsInNewWorkbook = lngOrgSINW
End If
End If
'Try to remove output sheet if error encountered:
If Not blnCmplt Then
wsOtpt.Parent.Close False
End If

'Release Objects:
Set wsSrch = Nothing
Set wsOtpt = Nothing
Set rngSrch = Nothing
Set rngCll = Nothing
Set rngChk = Nothing
Set rngCpy = Nothing

'Restore interface:
EnableInterface

'Set return value:
ProximitySearch = blnCmplt

Exit Function

'******* Error Handler *******
Err_Hnd:
'$PROBHIDE RETVAL_DISCARDED
MsgBox Err.Description, vbSystemModal + vbExclamation, "Error: " & Err.Number
'Return to Exit Procedure:
Resume Exit_Proc
Resume

End Function


Private Sub DisableInterface()

'---------------------------------------------------------------------------
' Procedure : DisableInterface
' Author : Aaron Bush
' Date : 06/11/2008
' Purpose : Provides a standardized way to set application to a working
' status.
' Remarks :
' Revisions :
'---------------------------------------------------------------------------

'Conditionally Invoke Error Handler:
#If Not m_blnErrorHandlersOff_c Then
On Error Resume Next
#End If

With Excel.Application
.EnableCancelKey = xlErrorHandler
.Cursor = xlWait
.ScreenUpdating = False
.EnableEvents = False
.Calculation = xlCalculationManual
.StatusBar = "Working..."
End With

End Sub

Private Sub EnableInterface()

'---------------------------------------------------------------------------
' Procedure : EnableInterface
' Author : Aaron Bush
' Date : 06/11/2008
' Purpose : Provides a standardized way to restore an application's
' interface.
' Remarks :
' Revisions :
'---------------------------------------------------------------------------

'Conditionally Invoke Error Handler:
#If Not m_blnErrorHandlersOff_c Then
On Error Resume Next
#End If

With Excel.Application
.EnableCancelKey = xlInterrupt
.Cursor = xlDefault
.ScreenUpdating = True
.EnableEvents = True
.Calculation = xlCalculationAutomatic
.StatusBar = False
End With

End Sub


Private Function SafeEval(ByVal value As String) As Boolean

'---------------------------------------------------------------------------
' Procedure : SafeEval
' Author : Aaron Bush
' Date : 06/11/2008
' Purpose : Performs the eval function without throwing errors on fail.
' Input(s) : value - The first value to be evaluated.
' Output(s) : The result of the eval, and false if a (suppressed) error is
' thrown.
' Remarks :
' Revisions :
'---------------------------------------------------------------------------



'Conditionally Invoke Error Handler:
#If Not m_blnErrorHandlersOff_c Then
On Error Resume Next
#End If

SafeEval = Excel.Evaluate(value)

End Function


Note: If you use it, I'd be curious to know how fast it works on a large recordset. Usually I optimize my code a bit more than this, but if I did that and retained the flexibility I wanted out of the parameters it would have ended up long.

[Simon Lloyd]

Wow! Aaron do you always carry that sledge hammer? if not a very well annotated sledge hammer! and you did all that before lunch, what is it you do again? lol!

[Oorang]

Sledgehammer? What is this "Sledgehammer" of which you speak?

[Simon Lloyd]

Sledgehammer? What is this "Sledgehammer" of which you speak?It's from a phrase "using a sledgehammer to crack a nut" it's just i read Bob's code and thought short to the point and functional,i read yours and thought its time i gave up VBA! i think you covered every angle in that code apart from which user ran the code and whether Angeline Jolie has any other tattoos that display the routing to the nearest burger bar!

I just meant that was a very full answer ;)

[Oorang]

rofl
Uhm well perhaps that was a little self indulgent. But I hardly ever get to code for excel now that I am more on the database side of things. I like to sharpen the skills from time to time so I err practiced on the OP:)

The funny (sad?) thing is that I nearly made it a bit longer to avoid using Ifs inside the loop (which I hate to do). There were also moments where I considered rolling my own Union method because Excel's performs poorly. And I discard the idea of copying each row individually to avoid the complex range copy problem that can arise (I decided in this context it was improbable to occur.) I even avoided using the faster for loop in favor of the easier to maintain for each method. But it seemed to run reasonably quick over 10k records so I decided to call it done.