For..Next Loop with problem

[alienscript]

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!

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

[Paul_Hossler]

[vba]
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
[/vba]


Also something like this ...
[VBA]
lastrow = Cells(Rows.Count, "I").End(xlUp).Row
[/VBA]

will always be the Active sheet

This is what I think you wanted
[VBA]
lastrow = ws.Cells(ws.Rows.Count, "I").End(xlUp).Row
[/VBA]

Since you set FindSht, you can use it ...
[VBA]
lastcol = FindSht.Cells.Find("*", SearchOrder:=xlByColumns, LookIn:=xlValues, _
SearchDirection:=xlPrevious).EntireColumn.Column
lastrw = FindSht.UsedRange.Rows.Count
[/VBA]




Paul

[alienscript]

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.

[SamT]

According to my Help, (2003,) Clear only applies to the Err object. So
[vba]FindSht.Range(Cells(2, 2), Cells(6666, 20)).Clear
[/vba]
Only clears any Err object gerenated by
[vba]FindSht.Range(Cells(2, 2), Cells(6666, 20))
[/vba]

I think, anyway.

SamT

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

[VBA]
.Cells(Row_Index, Column_Index)
[/VBA]

Does that work in VBA 2007?

[alienscript]

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

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

[Paul_Hossler]

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

[VBA]
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

[/VBA]

Paul

[alienscript]

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.

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