macro to loop through range and copy cell content

[4hhap]

I have several worksheets with data that goes up to 20,000 rows and 60 columns. The entries for a particular column (column W) were not properly entered and therefore a lot of the data have shifted to other columns. For instance instead of Column W you could find the correct entry either in Column Z, U, T, V, X etc. The data in column W should have only 2 characters; the first character should be a number and the second character should be a text (one of the alphabet. Examples are 2B, 5A, 3H, 4F). I wrote the macro below to loop through all the cells matching the content with a range where I have keyed all the possible data that could appear under column W. Where it find match it copies the content to a new range "BK". On the other hand where there is no correct entry on that row then it puts "NULL" in in there. However the macro doesn't seem to work. 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
End Sub

 

[BrianB]

In the absenceof other replies, I have tried a different approach :-

'=============================================================================
'- 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("A1:A10")
    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

 

[4hhap]

BrianB, I am higly humbled. Your solution worked like a miracle. Your solution is so good I wish the title or heading could be modified so that visitors to the board who have similar question will find an answer. Thanks you ve saved me many days headeach.