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]

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 ...


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


will always be the Active sheet

This is what I think you wanted


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


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


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





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

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

Only clears any Err object gerenated by

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



.Cells(Row_Index, Column_Index)


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



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

[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