Loop thru cells and copy content based on a criteria

[hhap]

I have a worksheet with data that goes up to 20,000 rows and 60 columns depending on the amount of data entries for the period. The entries for a particular column (column W) were not properly entered and therefore some of the data that should appear under column W appear under other columns but the same row.The data in column W should have only 2 characters; the first character should be a number and the second character should be an alphabet(eg 2B, 5A, 3H, 4F). For instance on one row instead of 2B appearing on Column W it would appear on the same row but under Column Z . In another row instead of , say, 5A,appearing on column W it would appear on say, column T or V or X but the same row. The rows are correct the problem is the data not appearing on column W. There can be only one correct entry for column W on each row. Also note that some of the entries in cloumn W are correct for some rows. Finally note that the list of entries for Column W are pre-defined and is listed in a range that the user can provide. I wrote the macro below to loop through all the cells matching the content with a range that the user will provide where the pre-defined data for column column W is . Where it finds a match it copies the content to a new range column "BK" on the same row. On the other hand where there is no correct entry on that row then it puts "NULL" in column "BK" for that row. However the macro doesn't seem to work; excel hangs for several minutes and nothing is produced. what am I doing wrong? I need help.

Sub FindOutletType() 
    Dim MasterList As Range 
    Dim I As Integer 
    Dim J As Integer 
    Dim FinalRow As Long 
    Dim FoundRow As Variant 
    On Error Resume Next 
     'get the ranges from the user.
     'The above on error handles cancel being      selected
    Set MasterList = Application.InputBox( _ 
   prompt:="Select the range to look for type    of outlet mapping",Type:=8) 
     'if no range supplied, exit macro
     
    If MasterList Is Nothing Then End 
     
     'restrict the ranges to the used range       on the sheet in case entire columns  selected above
    Set MasterList = Intersect(MasterList, ActiveSheet.UsedRange) 
     
     'rotate through each cell and see if it      is in the first range
     
    FinalRow = Cells(65536, 1).End(xlUp).Row 
    For I = 2 To FinalRow 
        For J = 1 To 55 
             
             'check only non-blank cells
     If Application.Trim(Cells(I, J))<> ""    Then 
                 'reset Err for each loop
                Err = 0 
                 'use the match function to        see if there is a match. Using a value
                 
                 'of Zero for the last argument means that an exact match is required
                FoundRow = Application.Match(Cells(I, J).Value, MasterList, 0) 
                 'If a match is found Err stays zero; Copy the cell in that case
                If Err = 0 Then 
                     
                    Cells(I, J).Copy Destination:=Cells(I, "BK") 
                     
                End If 
            End If 
             
        Next J 
     FoundRow = Application.Match(Cells(I, "BB").Value, MasterList, 0) 
        If Err <> 0 Then 
            Cells(I, "BK").Value = "NULL" 
        End If 
    Next I

 

[Crystalyzer]

Try this. I've tested it and it seems to do the trick.

Sub FindOutletType()
    Dim MasterList As Range
    Dim I As Integer
    Dim J As Integer
    Dim FinalRow As Long
    Dim FoundRow As Variant
    Dim Err As Integer
    Dim Val As String
   
    
    On Error Resume Next
     'get the ranges from the user.
     'The above on error handles cancel being      selected
    Set MasterList = Application.InputBox( _
   prompt:="Select the range to look for type    of outlet mapping", Type:=8)
     'if no range supplied, exit macro
     
    If MasterList Is Nothing Then End
     
     'restrict the ranges to the used range       on the sheet in case entire columns  selected above
    'Set MasterList = Intersect(MasterList, ActiveSheet.UsedRange)
     
     'rotate through each cell and see if it      is in the first range
     
    FinalRow = Cells(65536, 1).End(xlUp).Row
    For I = 2 To FinalRow
    Err = 0
        For J = 1 To 55
             
             'check only non-blank cells
     If Application.WorksheetFunction.Trim(Cells(I, J)) <> "" Then
                 'reset Err for each loop
                
                 'use the match function to see if there is a match. Using a value
                 'of Zero for the last argument means that an exact match is required
                Val = Cells(I, J).Value
                FoundRow = Application.WorksheetFunction.Match(Val, MasterList, 0)
                 'If a match is found Err stays zero; Copy the cell in that case
                'If Err = 0 Then
                If FoundRow <> "" Then
                    Cells(I, J).Copy Destination:=Cells(I, "BK")
                    Err = 1
                    FoundRow = Empty
                    Exit For
                End If
            End If
             
        Next J
     'FoundRow = Application.Match(Cells(I, "G").Value, MasterList, 0)
        If Err = 0 Then
            Cells(I, "BK").Value = "NULL"
        End If
    Next I
End Sub

Thanks and best regards,
-Lloyd

 

[hhap]

Crystalyzer thanks for your quick reply. However when I run the code I got a Run-time error '1004' on the following code

FoundRow = Application.WorksheetFunction.Match(Val, MasterList, 0)

The message that appears is as follows

"unable to get the Match property of the Worksheet Function Class"

I am using excel 2002.

 

[Crystalyzer]

I am using Excel 2003 and it works fine there. You may need to consult help in how to use worksheet functions in your code for 2002.

Sorry I couldn't be more help then that.

Thanks and best regards,
-Lloyd

 

[PHV]

I think Val is a VBA function, so avoid to name a variable so.

Hope This Helps, PH.
Want to get great answers to your Tek-Tips questions? Have a look at FAQ219-2884 or FAQ181-2886

 

[hhap]

Thanks to BrianB, from another site, I have a perfect solution to my question. It worked so well I decided to post it here for other users of the site as well.

'=============================================================================
'- macro checks each value in Colmn W with the checklist to see if it is valid
'- if not valid it checks coulumns T:Z in the same row for a valid value
'- value to BK if valid one found. Highlights bad entries.
'=============================================================================
Sub TEST()
    Dim ws As Worksheet
    Dim CheckList As Range  ' list of valid values
    Dim LastRow As Long
    Dim MyRow As Long
    Dim CheckRange As Range
    Dim CheckValue As String
    Dim FoundCella As Object
    Dim FoundCellb As Object
    Dim FoundValue As String
    '--------------------------------------------------------------------
    Application.Calculation = xlCalculationManual
    Set ws = ActiveSheet
    '--------------------------------------------------------------------
    Set CheckList = Worksheets("Sheet1").Range("A2:A29")
    LastRow = ws.Range("W65536").End(xlUp).Row
    '-------------------------------------------------------------------
    '- main loop through rows
    For MyRow = 2 To LastRow
        Application.StatusBar = _
                " Processing Row " & MyRow & " / " & LastRow
        CheckValue = ws.Cells(MyRow, 23).Value
        '- check if in approved list
        Set FoundCella = CheckList.Find(what:=CheckValue, lookat:=xlWhole)
        If FoundCella Is Nothing Then       ' value not in checklist
            '------------------------------------------------------------
            '- check other cells in the row T:Z for valid value
            '- includes W, but we know it is not there
            '-----------------------------------------------------------
            rg = "T" & MyRow & ":" & "Z" & MyRow
            Set CheckRange = ws.Range(rg)
            FoundValue = "NULL"
            For Each c In CheckRange.Cells
                CheckValue = c.Value
                '-------------------------------------------------------
                If Len(CheckValue) = 2 Then
                    Set FoundCellb = _
                        CheckList.Find(what:=CheckValue, lookat:=xlWhole)
                    If Not FoundCellb Is Nothing Then   ' value found
                        FoundValue = FoundCellb.Value
                        c.Interior.ColorIndex = 8
                        Exit For
                    End If
                End If
                '--------------------------------------------------------
            Next
            '- log correct value
            ws.Cells(MyRow, "BK").Value = FoundValue
            ws.Cells(MyRow, 23).Interior.ColorIndex = 8
        End If
    Next
    '---------------------------------------------------------------------
    '- finish
    MsgBox ("Done")
    Application.Calculation = xlCalculationAutomatic
    Application.StatusBar = False
End Sub

 

[Crystalyzer]

Gee thanks

and your welcome