VBA for Identifying and cutting to separate sheet based on certain criteria

[xcellrodeo]

Hi all,
I am looking for a solution for the following issue:
I have a large database (col.A to AA) with over 200000rows.
In Col. B I have data which looks like this:
X1094556
R3456992EX

What I would like is a VBA code which identifies all entries in Col B which end with "EX" and for the entire row to be cut and pasted to a separate spreadsheet ("Exclusions") starting in Cell B5 but with a function that copies new entries below the already existing ones (i.e using a Row Offset function or similar) so it doesn't overwrite existing entries.

Thanks

 

[Jerry Sullivan]

Hi xcellrodeo,

There are several methods that can be used. Since you have 200K rows, speed is probably a factor.

A few more details will help in suggesting some code that will be a good fit for your typical dataset.

1. Do you need more than just the Values copied? (For example, do you need Cell Formatting or Formulas to be copied)?

2. Approximately how many columns of data do you have?

3. Approximately what percentage of rows would typically be matches out of a 200K row dataset?

 

[xcellrodeo]

Hi Jerry Sullivan, thanks for your comments and request for clarification. Here is my response to your questions:
1. Just values (no formulas or cell formatting)
2. Col A to T
3. That depends on the data set (it is refreshed regularly). But I would expect to see no more than a third to a half (max) to fall into that criteria.
However, I couldn't guarantee that...just depends on data set.
Hope this helps. Thanks

 

[Jerry Sullivan]

Here's some code for you to try. On re-reading your OP, is realized you want to Cut or Move the matching records instead of Copying them.

Because this code removes records from your original source data, make sure to test thoroughly on a copy of your actual workbook.


Modify the sheet names where noted in the code to match your actual sheet names

Sub ExtractRowsMeetingCriterion()
'--example code showing one way to move rows meeting a criterion from
'  to another worksheet

'--assumes header row in Row 1 of both source and target sheets

 Dim lRowCount As Long, lColCount As Long, lRow As Long
 Dim lExtractCount As Long, lKeepCount As Long, lLastRow As Long
 Dim vData As Variant, vExtract As Variant, vKeep As Variant

 '--modify to match your sheet names
 Const sDATA_SHEET_NAME As String = "Data"
 Const sEXTRACT_SHEET_NAME As String = "Exclusions"
 
 '--modify to identify your column to be compared to criterion
 Const lCRITERION_COLUMN As Long = 2 'column "B"
 
 With Sheets(sDATA_SHEET_NAME)
   '--read all data including header row into array
   vData = .Cells.CurrentRegion.Value
   lRowCount = UBound(vData, 1)
   lColCount = UBound(vData, 2)
 End With
 
 '--size two arrays to hold records to move and records to keep
 ReDim vExtract(1 To lRowCount, 1 To lColCount)
 ReDim vKeep(1 To lRowCount, 1 To lColCount)
  
 '--step through data, copying records to extract or keep array
 For lRow = 2 To UBound(vData, 1)
    '--modify to create your match criterion
   If UCase$(Right(vData(lRow, lCRITERION_COLUMN), 2)) = "EX" Then
      lExtractCount = lExtractCount + 1
      writeRecord vSource:=vData, lSourceRow:=lRow, _
         vTarget:=vExtract, lTargetRow:=lExtractCount
   Else
      lKeepCount = lKeepCount + 1
      writeRecord vSource:=vData, lSourceRow:=lRow, _
         vTarget:=vKeep, lTargetRow:=lKeepCount
   End If
 Next lRow
 
 '--write arrays to worksheets
 With Sheets(sDATA_SHEET_NAME)
   .Range("A2").Resize(lRowCount - 1, lColCount).ClearContents
   .Range("A2").Resize(lKeepCount, lColCount).Value = vKeep
 End With
 
 With Sheets(sEXTRACT_SHEET_NAME)
   On Error Resume Next
   lLastRow = .Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
   On Error GoTo 0
   .Cells(lLastRow + 1, 1).Resize(lExtractCount, lColCount).Value = vExtract
 End With
 
End Sub

Private Sub writeRecord(ByVal vSource As Variant, ByVal lSourceRow As Long, _
   ByRef vTarget As Variant, ByVal lTargetRow As Long)

'--copies record from one array to another

'--assumes arrays already validated to:
   '  have same range of 2nd dimension (columns)
   '  be allocated at referenced 1st dimensions (rows)
   
 Dim lCol As Long
 
 For lCol = LBound(vSource, 2) To UBound(vSource, 2)
   vTarget(lTargetRow, lCol) = vSource(lSourceRow, lCol)
 Next lCol

End Sub

 

[xcellrodeo]

Thank you Jerry Sullivan