Find Function in a range does not work

**RAFA_NADAL** · 12-29-2019, 11:09 PM

Hi everyone,
I am trying to code a macro to transfer data from column Part Number of sheet 1 to row with similar Key at sheet 2:
1.png
2.png
My code is:
1) I clear the old data at sheet 2 and return to sheet 1.
2) I create 2 coulmns and add data to them to use latter.
3) I trim the key column and apply autofilter.
4) I copy key column to AK column and remove duplicate to use as variable for autofilter latter.
5) I use data of AK column to apply to autofilter and use Find function to get the required data and add to sheet 2.

My problem is that the Find function does not return the cell which contains the value and the code return Runtime Error 91: Object variable or with block variable not set.

Please check and help me to correct the fault.

**hernantorres23** · 12-30-2019, 01:32 AM

If you can share original source of data, I think that Power Query can resolve this.

But, follow your code, will find your first error (show below)...
Set cell = Cells(1 + t, 37)
'MsgBox cell.Address
firstCellAddress = cell

I changed the Set, to convert it, in a Range.
Although, I really don't understand what try to do, verify this error, before continuing

**LJMetzger** · 01-20-2020, 12:44 PM

Hi Rafa - love your forehand.

Nice code. You obviously have programming experience, but the Excel MacroRecorder has led you astray on how VBA can be written more efficiently.
'Select' causes code to run slower, and is not needed a great percentage of the time.

I was able to get your code to work with the small change in red below. Please NOTE that your sort does not work, because there is some code missing. However, when the proper sort code is added and the sort works, the workbook finishes with rows in the wrong place.

See the attached file that contains several different versions of Sub Main().

Sub MainOriginalNewDotFindWithRgSearch()

    Dim lrow As Long
    Dim LastRow As Long
    Dim t As Long
    Dim t1 As Long
    Dim a As Variant
    Dim b As Variant
    Dim rgSearch As Range
    Dim cell As Range
    Dim cell1 As Range
    Dim firstCellAddress As String


    'delete old data at sheet 2
    
    Sheets("Sheet34").Select
    Columns("H:BP").Select
    Selection.Delete Shift:=xlToLeft
    
    
    'return to sheet 1
    Sheets("TASK CARD").Select
    ActiveSheet.AutoFilterMode = False
    
    'create 2 cloumns
    Columns("C:C").Select
    Selection.Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
    Columns("C:C").Select
    Selection.Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
    
    'copy data to 2 columns
    Columns("A:B").Select
    Selection.Copy
    Range("C1").Select
    ActiveSheet.Paste
    Application.CutCopyMode = False
    
    'find last row
    lrow = Cells(Rows.Count, 10).End(xlUp).Row
    
    'add full data to 2 columns
    Cells(1, 3).Select
    For t = 1 To lrow - 1
        If IsEmpty(ActiveCell.Offset(t, 0).Value) = False Then
            a = Cells(1 + t, 3).Value
            b = Cells(1 + t, 4).Value
        Else
            Cells(1 + t, 3).Value = a
            Cells(1 + t, 4).Value = b
        End If
    Next t
    
    'trim the key data
    Cells(1, 6).Select
    For t = 1 To lrow - 1
        a = Trim(Cells(1 + t, 6).Value)
        Cells(1 + t, 6).Value = a
    Next t
    
    Cells(1, 7).Select
    For t = 1 To lrow - 1
        a = Trim(Cells(1 + t, 7).Value)
        Cells(1 + t, 7).Value = a
    Next t
    
    Cells(1, 8).Select
    For t = 1 To lrow - 1
        a = Trim(Cells(1 + t, 8).Value)
        Cells(1 + t, 8).Value = a
    Next t
    
    'apply filter
    Range(Cells(1, 3), Cells(lrow, 11)).AutoFilter
    
    'filter at AK column
    Columns("J:J").Copy
    Range("AK1").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Application.CutCopyMode = False
    ActiveSheet.Columns("AK:AK").RemoveDuplicates Columns:=1, Header:=xlNo
    
    'get data and add to sheet 2
    Set rgSearch = ActiveSheet.AutoFilter.Range
    Range("AK1").Select
    LastRow = Cells(Rows.Count, 37).End(xlUp).Row
    
    For t = 2 To LastRow - 1
        a = Cells(1 + t, 37).Value
        rgSearch.AutoFilter Field:=8, Criteria1:=a
        ActiveWorkbook.Worksheets("TASK CARD").AutoFilter.Sort.SortFields.Clear
        ActiveWorkbook.Worksheets("TASK CARD").AutoFilter.Sort.SortFields.Add Key:= _
        Range(Cells(1, 4), Cells(lrow, 4)), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption _
        :=xlSortTextAsNumbers
        'Set cell = rgSearch.Find(a)
        Set cell = rgSearch.Find(What:=a, LookIn:=xlValues)
        Debug.Print cell.Address
        firstCellAddress = cell.Address
        t1 = 1
        
        Do
            b = cell.Offset(0, -1).Value & " " & cell.Offset(0, -7).Value
            Sheets("Sheet34").Select
            Set cell1 = Range("G1:G3000").Find(a)
            
            If cell1 Is Nothing Then
                Debug.Print a
                GoTo abc
            End If

Dim x As Long
x = x + 1
            cell1.Offset(0, t1).Value = b
            Debug.Print x, cell1.Address, a, b
abc:
            t1 = t1 + 1
            Sheets("TASK CARD").Select
            Set cell = rgSearch.FindNext(cell)
        Loop While firstCellAddress <> cell.Address
        
        ActiveWorkbook.Worksheets("TASK CARD").AutoFilter.Sort.SortFields.Clear
    
    Next t
    
    Set rgSearch = Nothing
    Set cell = Nothing
    Set cell1 = Nothing
    
    Sheets("TASK CARD").Select
    ActiveSheet.AutoFilterMode = False
    Columns("AK:AK").Select
    Selection.Delete Shift:=xlToLeft
    Columns("C:D").Select
    Selection.Delete Shift:=xlToLeft
    
End Sub

To correct the sorting problem the following code has to be added:

Sub AutoFilterSortCorrection()

    ActiveWorkbook.Worksheets("Task Card").AutoFilter.Sort.SortFields.Clear
    ActiveWorkbook.Worksheets("Task Card").AutoFilter.Sort.SortFields.Add _
        Key:=Range("B1"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption _
        :=xlSortTextAsNumbers
    With ActiveWorkbook.Worksheets("Task Card").AutoFilter.Sort
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With

End Sub

The following suggestions may help you in the future:
a. Use 'Option Explicit'
To prevent typos from ruining days and weeks of work 'Option Explicit' is NEEDED at the top of each code module. This prevents errors caused by missspellings and FORCES every variable to be DECLARED (e.g. Dim i as Integer). https://www.excel-easy.com/vba/examp...-explicit.html
b. Use 'If then else' rather than 'goto abc' in most cases
c. Debug.Print (rather than MsgBox) outputs to the Immediate Window (Ctrl G in the debugger)
NOTE: Debug.Assert.False will act as a permanent breakpoint (often useful after a print)
d. Use Column Letters rather that Column Numbers (e.g. Cells(1, "D") is easier to read that Cells(1, 4) )
e. Qualify range to identify the worksheet (e.g. ws.Cells(1,4) rather than Cells(1,4) )
f. The .find routine can be hard to debug if all the parameters are not used, because the parameters are 'Sticky' if not explicitly named. See https://docs.microsoft.com/en-us/off...cel.range.find

Set rCellSource = rgSearch.Find(What:=a, _
   After:=rgSearch(1), _
   LookIn:=xlValues, _
   LookAt:=xlWhole, _
   SearchOrder:=xlByRows, _
   SearchDirection:=xlNext, _
   MatchCase:=False, _
   SearchFormat:=False)

g. Use of 'Select' slows down the code - especially inside of loops

Benchmark Times on my computer:
a. Original = 4.5 seconds
b. MainOriginalModified() average time = 3.0 seconds
c. MainOriginalOptimized() average time = 1.15 seconds
d. MainRewrite1() average time = 1.10 seconds
e. MainRewrite2() average time = 0.85 seconds

Changes:
MainOriginalModified() - Added/removed 'Task Card'/Dates in 'A' & 'B' white cells (instead of adding/deleting 2 columns). Implemented Sort. Added Temporary Use of Column 'Z' to contain original row numbers so original 'Task Card' row numbers can be restored.
MainOriginalOptimized() - Previous changes Plus - Removed Select where applicable. Added use of Worksheet Objects.
MainRewrite1() - Previous changes Plus - Replaced use of Column 'AK' with a 'Scripting Dictionary'. An Excel Scripting Dictionary is very good at identifying (and counting) unique items in a list.
Reference: http://www.experts-exchange.com/Soft...ss-in-VBA.html
Reference: http://www.snb-vba.eu/VBA_Dictionary_en.html
MainRewrite1() - Previous changes Plus - Replaced use of 'AutoFilter' with putting results in an array in memory and then sorting by date.

Lewis

**LJMetzger** · 01-20-2020, 12:50 PM

Continuation of previous post:

Rewrite 1 code:

Sub MainRewrite1()

    Dim wb As Workbook
    Dim wsSource As Worksheet
    Dim wsDestination As Worksheet

    Dim myDictionary As Object
    
    Dim myRangeConstants As Range
    Dim r As Range
    
    Dim i As Long
    Dim iLastRowColumnH As Long
    Dim iSourceRow As Long
    Dim sValue As String
    
    Dim lrow As Long
    Dim iDestinationSheetColumnOffset As Long
    Dim iCount As Long
    Dim a As Variant
    Dim b As Variant
    Dim rgSearch As Range
    Dim rCellSource As Range
    Dim rCellDestination As Range
    Dim firstCellAddress As String
    
    Dim xStartSecondsSinceMidnight As Double
    xStartSecondsSinceMidnight = Timer
    
    'Turn Off Screen Updating to Improve Performance and to Reduce Screen Flicker
    Application.ScreenUpdating = False
    
    'Create Worksheet Objects
    Set wb = ThisWorkbook       'The Workbook that contains the VBA code
    Set wsSource = wb.Sheets("TASK CARD")
    Set wsDestination = wb.Sheets("Sheet34")

    'remove old data at sheet 2
    wsDestination.Columns("H:BP").ClearContents
    
    
    'return to sheet 1
    wsSource.AutoFilterMode = False
    
         
    'Put Row Numbers in Column 'Z' on Sheet 'Task Data' (used to restore original Row Order)
    'Add Dates in the 'White Cells in Column 'B" on Sheet 'Task Card'
    Call PutRowNumbersInColumnZOnSheetTaskData(wsSource)
    Call AddOrRemoveDataFromWhiteCellsOnSheetTaskCardColumnsAandB("Add", wsSource)
    
    'find last row
    lrow = wsSource.Cells(Rows.Count, "H").End(xlUp).Row
    
    'trim the key data
    Set myRangeConstants = wsSource.Range("D:F").SpecialCells(xlCellTypeConstants)
    For Each r In myRangeConstants
      r.Value = Application.WorksheetFunction.Trim(r.Value)
    Next r
    
    'Create the Dictionary Object
    'Reference: http://www.experts-exchange.com/Software/Office_Productivity/Office_Suites/MS_Office/A_3391-Using-the-Dictionary-Class-in-VBA.html
    'Reference: http://www.snb-vba.eu/VBA_Dictionary_en.html
    'KEY:  Column 'H' Concatenation
    'ITEM: 1 (Dummy Value)
    Set myDictionary = CreateObject("Scripting.Dictionary")
    ''myDictionary.CompareMode = vbBinaryCompare 'case sensitive
    myDictionary.CompareMode = vbTextCompare 'case insensitive

    'Get the Last Row in Column H
    iLastRowColumnH = wsSource.Columns("H").Find(What:="*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
    
    For iSourceRow = 3 To iLastRowColumnH
    
      sValue = Trim(wsSource.Cells(iSourceRow, "H").Value)
      
      'Add a value to the 'Dictionary'  (if it doesn't exist)
      If Len(sValue) > 0 Then
        If myDictionary.exists(sValue) = False Then
          myDictionary.Add sValue, 1
        End If
      End If
      
    Next iSourceRow

''''    For i = 0 To myDictionary.Count - 1
''''      Debug.Print i + 1, myDictionary.keys()(i), myDictionary.items()(i)
''''      a = myDictionary.keys()(i)
''''    Next i
    
    
    'apply filter
    'wsSource.Range(wsSource.Cells(1, "B"), wsSource.Cells(lRow, "I")).AutoFilter
    wsSource.Range(wsSource.Cells(1, "B"), wsSource.Cells(lrow, "Z")).AutoFilter
    Set rgSearch = wsSource.AutoFilter.Range
    
    
    'get data and add to sheet 2
    For i = 0 To myDictionary.Count - 1
        
        'Get the Next Item to Search For
        a = myDictionary.keys()(i)
    
        'AutoFilter by KEY
        'AutoFilter Sort by Date
        rgSearch.AutoFilter Field:=7, Criteria1:=a
        wsSource.AutoFilter.Sort.SortFields.Clear
        wsSource.AutoFilter.Sort.SortFields.Add _
            Key:=wsSource.Range("B1"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortTextAsNumbers
        With wsSource.AutoFilter.Sort
            .Header = xlYes
            .MatchCase = False
            .Orientation = xlTopToBottom
            .SortMethod = xlPinYin
            .Apply
        End With
        
        Set rCellSource = rgSearch.Find(What:=a, _
                      After:=rgSearch(1), _
                      LookIn:=xlValues, _
                      LookAt:=xlWhole, _
                      SearchOrder:=xlByRows, _
                      SearchDirection:=xlNext, _
                      MatchCase:=False, _
                      SearchFormat:=False)
        'Debug.Print i+1, a, rCellSource.Address
        
        
        firstCellAddress = rCellSource.Address
        iDestinationSheetColumnOffset = 1
        
        Do
            b = rCellSource.Offset(0, -1).Value & " " & rCellSource.Offset(0, -7).Value
            'NOTE: Column 'G' data on 'Sheet34' has 'Trailing Blanks' need xlPart
            Set rCellDestination = wsDestination.Range("G1:G3000").Find(What:=a, _
                      After:=wsDestination.Range("G1:G3000")(1), _
                      LookIn:=xlValues, _
                      LookAt:=xlPart, _
                      SearchOrder:=xlByRows, _
                      SearchDirection:=xlNext, _
                      MatchCase:=False, _
                      SearchFormat:=False)
            
            If Not rCellDestination Is Nothing Then
            
                ''''''''''''''''''''''''''''
                ''''''''''''''''''''''''''''
                iCount = iCount + 1
                'Debug.Print Format(iCount, "0000"), i + 1, rCellDestination.Address(False, False), b 'Output to Immediate Window (Ctrl G in the Debugger)
                ''''''''''''''''''''''''''''
                ''''''''''''''''''''''''''''
            
                rCellDestination.Offset(0, iDestinationSheetColumnOffset).Value = b
            End If
            
            iDestinationSheetColumnOffset = iDestinationSheetColumnOffset + 1
            Set rCellSource = rgSearch.FindNext(rCellSource)
        Loop While firstCellAddress <> rCellSource.Address
        
    Next i
    
    'Remove AutoFilter
    'Remove Dates from White Cells in Column 'B' on Sheet 'Task Data'
    wsSource.AutoFilterMode = False
    Call AddOrRemoveDataFromWhiteCellsOnSheetTaskCardColumnsAandB("Remove", wsSource)
    
    'Restore Original Row Order
    'Remove the Numbers from Column 'Z'
    Call RestoreOriginalRowNumbers(wsSource, lrow)
    wsSource.Columns("Z").ClearContents
    
    'AutoFit the Columns on the Destination Sheet
    wsDestination.Columns("H:BP").Columns.AutoFit
    
    'Clear the Dictionary
    myDictionary.RemoveAll
    
    'Clear Object Pointers
    Set wb = Nothing
    Set wsSource = Nothing
    Set wsDestination = Nothing

    Set rgSearch = Nothing
    Set rCellSource = Nothing
    Set rCellDestination = Nothing
    Set myDictionary = Nothing
    
    Debug.Print "Elapsed time = " & Timer - xStartSecondsSinceMidnight & " seconds.      ";
    Debug.Print iCount & " cells were written to on 'Sheet34'."
    
    'Restore Screen Updating
    Application.ScreenUpdating = True

End Sub

Lewis

**LJMetzger** · 01-20-2020, 12:51 PM

Continuation of previous post:

Rewrite2() Code:

Sub MainRewrite2()

    Dim wb As Workbook
    Dim wsSource As Worksheet
    Dim wsDestination As Worksheet

    Dim myDictionary As Object
    
    Dim myRangeConstants As Range
    Dim r As Range
    Dim rgSearch As Range
    Dim rCellSource As Range
    Dim rCellDestination As Range
    
    Dim a As Variant
    Dim b As Variant
    
    Dim i As Long
    Dim ii As Long
    Dim iCount As Long
    Dim iCountThisKey As Long
    Dim iDateCounter As Long
    Dim iDestinationSheetColumnOffset As Long
    Dim iLastRowColumnH As Long
    Dim iSourceRow As Long
    Dim lrow As Long
    
    Dim firstCellAddress As String
    Dim sArray() As String
    Dim sConcatenation As String
    Dim sTaskCardSearchRange As String
    Dim sValue As String
    Dim sValueColumnA As String
    Dim sValueColumnB As String
    Dim sValueColumnG As String
    
    Dim xStartSecondsSinceMidnight As Double
    xStartSecondsSinceMidnight = Timer
    
    'Turn Off Screen Updating to Improve Performance and to Reduce Screen Flicker
    Application.ScreenUpdating = False
    
    'Create Worksheet Objects
    Set wb = ThisWorkbook       'The Workbook that contains the VBA code
    Set wsSource = wb.Sheets("TASK CARD")
    Set wsDestination = wb.Sheets("Sheet34")

    'remove old data at sheet 2
    wsDestination.Columns("H:BP").ClearContents
    
    'Make sure 'AutoFilter' is OFF
    wsSource.AutoFilterMode = False
         
    'Put Row Numbers in Column 'Z' on Sheet 'Task Data' (used to restore original Row Order)
    'Add Dates in the 'White Cells in Column 'B" on Sheet 'Task Card'
    Call PutRowNumbersInColumnZOnSheetTaskData(wsSource)
    Call AddOrRemoveDataFromWhiteCellsOnSheetTaskCardColumnsAandB("Add", wsSource)
    
    'find last row in the Key Column
    'Create the 'Task Card' Search Range
    lrow = wsSource.Cells(Rows.Count, "H").End(xlUp).Row
    
    'trim the key data
    Set myRangeConstants = wsSource.Range("D:F").SpecialCells(xlCellTypeConstants)
    For Each r In myRangeConstants
      r.Value = Application.WorksheetFunction.Trim(r.Value)
    Next r
    
    
    ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
    'Find the Unique Items in Column 'H'
    ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
    
    ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
    'The Dictionary contains the list of items that were in Column 'AK'
    '
    'Create the Dictionary Object
    'Reference: http://www.experts-exchange.com/Software/Office_Productivity/Office_Suites/MS_Office/A_3391-Using-the-Dictionary-Class-in-VBA.html
    'Reference: http://www.snb-vba.eu/VBA_Dictionary_en.html
    'KEY:  Column 'H' Concatenation
    'ITEM: 1 (Dummy Value)
    ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
    Set myDictionary = CreateObject("Scripting.Dictionary")
    ''myDictionary.CompareMode = vbBinaryCompare 'case sensitive
    myDictionary.CompareMode = vbTextCompare 'case insensitive

    'Get the Last Row in Column H
    iLastRowColumnH = wsSource.Columns("H").Find(What:="*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
    
    For iSourceRow = 3 To iLastRowColumnH
    
      sValue = Trim(wsSource.Cells(iSourceRow, "H").Value)
      
      'Add a value to the 'Dictionary'  (if it doesn't exist)
      If Len(sValue) > 0 Then
        If myDictionary.exists(sValue) = False Then
          myDictionary.Add sValue, 1
        End If
      End If
      
    Next iSourceRow

'''''    For i = 0 To myDictionary.Count - 1
'''''      Debug.Print i + 1, myDictionary.keys()(i), myDictionary.items()(i)
'''''      a = myDictionary.keys()(i)
'''''    Next i
    
    
    ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
    'Get Data and Add to 'Sheet34'
    ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
    
    'Create the 'Task Card' Search Range
    sTaskCardSearchRange = "H1:H" & lrow
    Set rgSearch = wsSource.Range(sTaskCardSearchRange)
    
    'get data and add to sheet 2
    For i = 0 To myDictionary.Count - 1
    
        '''''''''''''''''''''''''''''''''''''''''''''''''''
        'Get Data From Sheet 'Task Card' and sort the Data by Date
        '''''''''''''''''''''''''''''''''''''''''''''''''''
        
        'Initialize the Array that contains the results from Sheet 'Task Card'
        iCountThisKey = 0
        ReDim sArray(1 To 1)
        
        'Get the Next Item to Search For
        a = myDictionary.keys()(i)
        
        Set rCellSource = rgSearch.Find(What:=a, _
                      After:=rgSearch(1), _
                      LookIn:=xlValues, _
                      LookAt:=xlWhole, _
                      SearchOrder:=xlByRows, _
                      SearchDirection:=xlNext, _
                      MatchCase:=False, _
                      SearchFormat:=False)
        'Debug.Print i + 1, a, rCellSource.Address
        
        firstCellAddress = rCellSource.Address
        
        Do
            
            'Get the Data from this 'Key
            iSourceRow = rCellSource.Row
            sValueColumnA = Trim(wsSource.Cells(iSourceRow, "A").Value)   'Task Card
            sValueColumnB = Trim(wsSource.Cells(iSourceRow, "B").Value)   'Date
            sValueColumnG = Trim(wsSource.Cells(iSourceRow, "G").Value)   'Part Number
        
            'Convert the Date to the Number of Days since the 'Base Date'
            If Len(sValueColumnB) = 0 Then
              iDateCounter = 0
            ElseIf IsDate(sValueColumnB) = True Then
              iDateCounter = CLng(CDate(sValueColumnB))
            Else
              iDateCounter = 0
            End If
        
            'Create a Concatenation - 'Date' 'Tilde' 'Part Number' 'Space' 'Task Card'
            'Put the Concatenation in an Array to be Sorted
            sConcatenation = Format(iDateCounter, "000000") & "~" & sValueColumnG & " " & sValueColumnA
            iCountThisKey = iCountThisKey + 1
            ReDim Preserve sArray(1 To iCountThisKey)
            sArray(iCountThisKey) = sConcatenation
            
            'Get the Next 'Match'
            Set rCellSource = rgSearch.FindNext(rCellSource)
        Loop While firstCellAddress <> rCellSource.Address
        
        'Sort the Array
        Call LjmBubbleSortString(sArray)
            
        
        '''''''''''''''''''''''''''''''''''''''''''''''''''
        'Loop thru elements in the Array
        'Put the Value in the Destination Sheet
        '''''''''''''''''''''''''''''''''''''''''''''''''''
            
        'Put Destination Sheet Code Here
        iDestinationSheetColumnOffset = 0
        
        
        'Find the Target Value on the Destination Sheet
        'NOTE: Column 'G' data on 'Sheet34' has 'Trailing Blanks' need xlPart
        Set rCellDestination = wsDestination.Range("G1:G3000").Find(What:=a, _
                      After:=wsDestination.Range("G1:G3000")(1), _
                      LookIn:=xlValues, _
                      LookAt:=xlPart, _
                      SearchOrder:=xlByRows, _
                      SearchDirection:=xlNext, _
                      MatchCase:=False, _
                      SearchFormat:=False)
            
        
          'If there is a Match put the 'Part Number' and 'Task Card' Concatenation on the Destination Sheet
          'for each Item in the Sorted Array
          If Not rCellDestination Is Nothing Then
        
              For ii = 1 To iCountThisKey
        
                  'Get the Next Concatenation
                  'Strip off the first 7 characters (6 character data plus Tilde '~')
                  b = sArray(ii)
                  b = Right(b, (Len(b) - 7))
          
                  ''''''''''''''''''''''''''''
                  ''''''''''''''''''''''''''''
                  iCount = iCount + 1
                  'Debug.Print Format(iCount, "0000"), i + 1, rCellDestination.Address(False, False), b 'Output to Immediate Window (Ctrl G in the Debugger)
                  ''''''''''''''''''''''''''''
                  ''''''''''''''''''''''''''''
            
                  iDestinationSheetColumnOffset = ii
                  rCellDestination.Offset(0, iDestinationSheetColumnOffset).Value = b
              
              Next ii
          End If
        
    Next i
    
    
    '''''''''''''''''''''''''''''''''''''''''''''''''''
    'Termination
    '''''''''''''''''''''''''''''''''''''''''''''''''''
    
    'Remove Dates from White Cells in Column 'B' on Sheet 'Task Data'
    Call AddOrRemoveDataFromWhiteCellsOnSheetTaskCardColumnsAandB("Remove", wsSource)
    
    'Restore Original Row Order
    'Remove the Numbers from Column 'Z'
    Call RestoreOriginalRowNumbers(wsSource, lrow)
    wsSource.Columns("Z").ClearContents
    
    'AutoFit the Columns on the Destination Sheet
    wsDestination.Columns("H:BP").Columns.AutoFit
    
    'Clear the Dictionary
    myDictionary.RemoveAll
    
    'Clear Object Pointers
    Set wb = Nothing
    Set wsSource = Nothing
    Set wsDestination = Nothing

    Set rgSearch = Nothing
    Set rCellSource = Nothing
    Set rCellDestination = Nothing
    Set myDictionary = Nothing
    Set myRangeConstants = Nothing
    'Note 'r' does not have to be cleared - only used in a loop - cleared automatically be Excel on Sub 'End' statement
    
    Debug.Print "Elapsed time = " & Timer - xStartSecondsSinceMidnight & " seconds.      ";
    Debug.Print iCount & " cells were written to on 'Sheet34'."
    
    'Restore Screen Updating
    Application.ScreenUpdating = True

End Sub

Lewis

Find Function in a range does not work

LinkBack

Thread Tools

Rate This Thread

Display

Hybrid View

Find Function in a range does not work

Re: Find Function in a range does not work

Re: Find Function in a range does not work

Re: Find Function in a range does not work

Re: Find Function in a range does not work

Thread Information

Users Browsing this Thread

Similar Threads

[SOLVED] Use variable to find and copy range with find function

[SOLVED] Why my find function not work all the time here?

[SOLVED] Find part of work in range

[SOLVED] Find a Text in a work book and then deleting a range of cells above it

Can't make .Find function work

Using Range.find() doesn't work when the text you look for is in merged cells

Trying to get MATCH or FIND function to work

Bookmarks

Bookmarks

Posting Permissions