For..Next Loop with problem

Hi, VBA community!

I tried to find the value of the list in column A in Sheet "Find" by looping through all the other sheets ws. If the value in ws is found (depending on whether the value found in ws is in column I or column M), I then want to populate the values found to the desired columns in Sheet "Find" (columns I to L or columns M to P). I can't seem to find out what went wrong.

I attach the example workbook. I hope to be able to get some help here. I'm using Excel 2003. Thanks in advance!

Code:

---

Sub test()
Dim lastcol As Integer, lastrw As Long, lastrow As Long, i As Long
Dim ws As Worksheet, FindSht As Worksheet, vFind, rFound As Range, rFoundCol As Integer

Set FindSht = Sheets("Find")
FindSht.Range(Cells(2, 2), Cells(6666, 20)).Clear
lastcol = Sheets("Find").Cells.Find("*", SearchOrder:=xlByColumns, LookIn:=xlValues, _
    SearchDirection:=xlPrevious).EntireColumn.Column
lastrw = Sheets("Find").UsedRange.Rows.Count

For i = 2 To lastrw
vFind = FindSht.Cells(i, 1)
    For Each ws In Worksheets
        On Error Resume Next
        lastrow = Cells(Rows.Count, "I").End(xlUp).Row
        If ws.Name <> FindSht Then
            ws.Select

            Set rFound = Cells.Find(what:=vFind, After:=[A1], LookIn:=xlFormulas, LookAt:= _
            xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False)
                If Not rFound Is Nothing Then
                    rFoundCol = rFound.Column
                    If Cells(5, rFoundCol).Value = "FROM" Then
                        FindSht.Cells(i, rFoundCol).Value = rFound
                        FindSht.Cells(i, rFoundCol + 1).Value = rFound.Offset(, 1)
                        FindSht.Cells(i, rFoundCol + 2).Value = rFound.Offset(, 2)
                        FindSht.Cells(i, rFoundCol + 3).Value = rFound.Offset(, 3)
                    ElseIf Cells(5, rFoundCol).Value = "TO" Then
                        FindSht.Cells(i, rFoundCol).Value = rFound
                        FindSht.Cells(i, rFoundCol + 1).Value = rFound.Offset(, 1)
                        FindSht.Cells(i, rFoundCol + 2).Value = rFound.Offset(, 2)
                        FindSht.Cells(i, rFoundCol + 3).Value = rFound.Offset(, 3)
                    End If
                End If
        End If
    Next ws
Next i

Application.ScreenUpdating = True
Sheets("Find").Select
Set FindSht = Nothing
Set rFound = Nothing
End Sub

---

Code:

---

Set FindSht = Sheets("Find")
......
For i = 2 To lastrw
    vFind = FindSht.Cells(i, 1)
    For Each ws In Worksheets
        'this hides the next error
        On Error Resume Next
        lastrow = Cells(Rows.Count, "I").End(xlUp).Row
        'FindSht is an Worksheet object
        ' You probably meant <> FindSht.Name
        ' That's why I don't like to use On Error Resume Next like that
        If ws.Name <> FindSht Then

---

Also something like this ...

Code:

---

lastrow = Cells(Rows.Count, "I").End(xlUp).Row

---

will always be the Active sheet

This is what I think you wanted

Code:

---

lastrow = ws.Cells(ws.Rows.Count, "I").End(xlUp).Row

---

Since you set FindSht, you can use it ...

Code:

---

lastcol = FindSht.Cells.Find("*", SearchOrder:=xlByColumns, LookIn:=xlValues, _
    SearchDirection:=xlPrevious).EntireColumn.Column
lastrw = FindSht.UsedRange.Rows.Count

---

Paul

Paul,

Thanks. I changed to ws.Name <> FindSht.Name, still nothing populated. More so the iteration seems to last very long. Something else isn't right but I can't figure out why.

According to my Help, (2003,) Clear only applies to the Err object. So

Code:

---

FindSht.Range(Cells(2, 2), Cells(6666, 20)).Clear

---

Only clears any Err object gerenated by

Code:

---

FindSht.Range(Cells(2, 2), Cells(6666, 20))

---

I think, anyway.

SamT

ps to all: I notice a lot of people are using strings for the Column_Index in the construct

Code:

---

.Cells(Row_Index, Column_Index)

---

Does that work in VBA 2007?

I changed according to the suggestions. Tried again but the iterations now runs without stop. What is wrong with the loop?

Code:

---

Option Explicit
Sub test()
Dim lastcol As Integer, lastrw As Long, lastrow As Long, i As Long
Dim ws As Worksheet, FindSht As Worksheet, vFind, rFound As Range, rFoundCol As Integer

Set FindSht = Sheets("Find")
FindSht.Range(Cells(2, 2), Cells(6666, 20)).ClearContents
lastcol = FindSht.Cells.Find("*", SearchOrder:=xlByColumns, LookIn:=xlValues, _
  SearchDirection:=xlPrevious).EntireColumn.Column
lastrw = FindSht.UsedRange.Rows.Count

For i = 2 To lastrw
    vFind = FindSht.Cells(i, 1)
    For Each ws In Worksheets
        lastrow = ws.Cells(ws.Rows.Count, "I").End(xlUp).Row
        If ws.Name <> FindSht.Name Then
            ws.Select
            Set rFound = Cells.Find(what:=vFind, After:=[A1], LookIn:=xlFormulas, LookAt:= _
            xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False)
                If Not rFound Is Nothing Then
                    rFoundCol = rFound.Column
                    If Cells(1, rFoundCol).Value = "FROM" Then
                        FindSht.Cells(i, rFoundCol).Value = rFound
                        FindSht.Cells(i, rFoundCol + 1).Value = rFound.Offset(, 1)
                        FindSht.Cells(i, rFoundCol + 2).Value = rFound.Offset(, 2)
                        FindSht.Cells(i, rFoundCol + 3).Value = rFound.Offset(, 3)
                    ElseIf Cells(1, rFoundCol).Value = "TO" Then
                        FindSht.Cells(i, rFoundCol).Value = rFound
                        FindSht.Cells(i, rFoundCol + 1).Value = rFound.Offset(, 1)
                        FindSht.Cells(i, rFoundCol + 2).Value = rFound.Offset(, 2)
                        FindSht.Cells(i, rFoundCol + 3).Value = rFound.Offset(, 3)
                    End If
                End If
        End If
    Next ws
Next i

Application.ScreenUpdating = True
Set FindSht = Nothing
Set rFound = Nothing
End Sub

---

I added comments to my suggestions, but there's only one item that populates. Spot checking, that seems like all that should

Code:

---

Sub test()
    Dim lastcol As Integer, lastrw As Long, lastrow As Long, i As Long
    Dim ws As Worksheet, FindSht As Worksheet, vFind, rFound As Range, rFoundCol As Integer
    Dim rCell As Range
    Set FindSht = Sheets("Find")
    'any reason why 6666?
    FindSht.Cells(2, 2).Resize(6666, 20).ClearContents
    lastcol = FindSht.Cells.Find("*", SearchOrder:=xlByColumns, LookIn:=xlValues, _
    SearchDirection:=xlPrevious).EntireColumn.Column
    '    lastrw = FindSht.UsedRange.Rows.Count
    '    lastrw = 6666
    '    lastrw = 5 this way
    lastrw = FindSht.Cells(1, 1).CurrentRegion.Rows.Count
    'you've got trailing spaces in your data
    For Each ws In Worksheets
        For Each rCell In ws.Cells(1, 1).CurrentRegion.Cells
            rCell.Value = Trim(rCell.Value)
        Next
    Next
    For i = 2 To lastrw
        vFind = FindSht.Cells(i, 1)
        For Each ws In Worksheets
            If ws.Name = FindSht.Name Then GoTo GetNextSheet
            'need to use specific sheet (ws.) for Cells and Rows
            lastrow = ws.Cells(ws.Rows.Count, "I").End(xlUp).Row
            'wouldn't you want to look in Values instead of the Formulas which are not there?
            Set rFound = ws.Cells.Find(what:=vFind, After:=[A1], LookIn:=xlValues, LookAt:= _
            xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False)
            If rFound Is Nothing Then GoTo GetNextRow
            rFoundCol = rFound.Column
            'FROM and TO are in the First not fifth row
            If ws.Cells(1, rFoundCol).Value = "FROM" Then
                FindSht.Cells(i, rFoundCol).Value = rFound
                FindSht.Cells(i, rFoundCol + 1).Value = rFound.Offset(, 1)
                FindSht.Cells(i, rFoundCol + 2).Value = rFound.Offset(, 2)
                FindSht.Cells(i, rFoundCol + 3).Value = rFound.Offset(, 3)
            ElseIf ws.Cells(1, rFoundCol).Value = "TO" Then
                FindSht.Cells(i, rFoundCol).Value = rFound
                FindSht.Cells(i, rFoundCol + 1).Value = rFound.Offset(, 1)
                FindSht.Cells(i, rFoundCol + 2).Value = rFound.Offset(, 2)
                FindSht.Cells(i, rFoundCol + 3).Value = rFound.Offset(, 3)
            End If
            GetNextSheet:
        Next ws
        GetNextRow:
    Next i
    Application.ScreenUpdating = True
    Sheets("Find").Select
End Sub

---

Paul

Hi,

I finally have it worked with further edit. It copies all formats and works fine in xl 2003 but not in xl 2002 where it can't copy rows that have some special formats and styles in certain worksheets.

Code:

---


Sub Test()
Dim lastcol As Integer, lastrw As Long, lastcolumn As Integer, i As Long, j As Long, k As Long
Dim ws As Worksheet, FindSht As Worksheet, vFind, rSearch As Range
Dim rFound As Range, rFoundRow As Long, FirstAddress As String, NextAddress As String
Dim rNextFoundRow As Long

Sheets("Find").Activate
Set FindSht = Sheets("Find")
FindSht.Range(Cells(2, 2), Cells(3456, 22)).ClearContents
FindSht.Range(Cells(2, 2), Cells(3456, 22)).ClearFormats
lastcol = FindSht.Cells.Find("*", SearchOrder:=xlByColumns, LookIn:=xlValues, _
  SearchDirection:=xlPrevious).EntireColumn.Column
lastrw = FindSht.Cells(FindSht.Rows.Count, "A").End(xlUp).Row

k = 1
j = 1
For i = 2 To lastrw
vFind = FindSht.Cells(i, 1)
 
  For Each ws In ThisWorkbook.Worksheets
    If ws.Name <> FindSht.Name Then
        Application.ScreenUpdating = False
        ws.Activate
        Set rSearch = ws.Range("I9:I" & Cells(65536, 9).End(xlUp).Row)
       
        Set rFound = rSearch.Find(What:=vFind, LookIn:=xlValues, LookAt:= _
            xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False)

        If Not rFound Is Nothing Then
            FirstAddress = rFound.Address
            rFoundRow = rFound.Row
            NextAddress = ""

            j = j + 1
            k = k + 1
            Do While Not rFound Is Nothing And rFound.Address <> NextAddress
                ws.Range("F" & rFoundRow & ":R" & rFoundRow & "").Copy FindSht.Cells(k, "H")
                FindSht.Cells(j, "B").Value = ws.Name
                ws.Range("A" & rFoundRow).End(xlUp).Resize(1, 5).Copy FindSht.Cells(j, "C")
                ws.Range("S" & rFoundRow).End(xlUp).Copy FindSht.Cells(j, "U")
       
                Set rFound = rSearch.FindNext(rFound)
                NextAddress = rFound.Address
                rNextFoundRow = rFound.Row
               
                If (NextAddress <> FirstAddress) Then
                    j = j + 1
                    k = k + 1
                    ws.Range("F" & rNextFoundRow & ":R" & rNextFoundRow & "").Copy FindSht.Cells(k, "H")
                    FindSht.Cells(j, "B").Value = ws.Name
                    ws.Range("A" & rNextFoundRow).End(xlUp).Resize(1, 5).Copy FindSht.Cells(j, "C")
                    ws.Range("S" & rNextFoundRow).End(xlUp).Copy FindSht.Cells(j, "U")
                End If
            Loop
        End If
    End If
  Next ws
Next i

'Undo the last selection for copying
Application.CutCopyMode = False
                   
FindSht.Activate
Range("A2").Select
Application.ScreenUpdating = True
Set rFound = Nothing
Set rSearch = Nothing
Set FindSht = Nothing
End Sub

---