How to scroll in HorizontallistView programmatically?

Auto scroll results

• QUESTION: this is the code I am having problems with. Sub ScrollScores() Dim r As Range, cell As Range, ii As Long, i As Long Dim sh As Worksheet, v As Variant, idex As Long Dim vv As Variant vv = Array(1, 4, 1, 1) 'for example v = Array("Net", "Gross", "Sheet1") idex = LBound(v) Do Set sh = Worksheets(v(idex)) ' loops through the specified sheets If idex = UBound(v) Then idex = LBound(v) Else idex = idex + 1 End If With sh Select Case .Name Case "Net" Set rcol = .Range("A2") Case "Gross" Set rcol = .Range("B2") Case "Sheet1" Set rcol = .Range("C2") Case Else Set rcol = .Range("D2") End Select .Activate .Range("J1").ClearContents .Range("A1").Select .Range("J1").Activate .Rows.EntireRow.Hidden = False Set r = .Range("A2", .Cells(.Rows.Count, "A").End(xlUp)) ' change B5 to the column you want to sort on, change xldescending to xlascending if that is ' what you want to do ' r.EntireRow.Hidden = False r.EntireRow.Sort Key1:=rcol, Order1:=xlDescending, Header:=xlNo For Each cell In r This is the line I get the error on. If InStr(1, sh.Cells(cell.Row, "H"), "Awaiting Scorecare", vbTextCompare) Or sh.Cells(cell.Row, "C") = vv(i) Then cell.EntireRow.Hidden = True End If Next End With DoEvents For Each cell In r If cell.EntireRow.Hidden = False Then DoEvents ActiveWindow.ScrollRow = cell.Row DoEvents Application.ScreenUpdating = True DoEvents For i = 1 To 10000 ' 10000 Then ii = 0 Else ii = ii + 1 End If 'If ii > 10000 Then If Not IsEmpty(Range("J1")) Then Exit Sub DoEvents Next 'For i = 1 To 10000 DoEvents End If 'if cell.EntireRow.Hidden = False then Next 'For Each cell In r DoEvents Loop While IsEmpty(Range("J1")) End Sub ANSWER: Alan, Since you are already using a case statement to define parameters particular to each sheet, you might as well use that same case statement to define the value. So instead of using the vv(i) array, I defined a variable ival as Long (change it to double if the number will be a decimal or change it to variant if it could be a number or a string/text value) Sub ScrollScores() Dim r As Range, cell As Range, ii As Long, i As Long Dim sh As Worksheet, v As Variant, idex As Long Dim vv As Variant, ival As Long v = Array("Net", "Gross", "Sheet1") idex = LBound(v) Do Set sh = Worksheets(v(idex)) ' loops through the specified sheets If idex = UBound(v) Then idex = LBound(v) Else idex = idex + 1 End If With sh Select Case .Name Case "Net" Set rcol = .Range("A2") ival = 1 Case "Gross" Set rcol = .Range("B2") ival = 4 Case "Sheet1" Set rcol = .Range("C2") ival = 1 Case Else Set rcol = .Range("D2") ival = 1 End Select .Activate .Range("J1").ClearContents .Range("A1").Select .Range("J1").Activate .Rows.EntireRow.Hidden = False Set r = .Range("A2", .Cells(.Rows.Count, "A").End(xlUp)) ' change B5 to the column you want to sort on, change xldescending to xlascending if that is ' what you want to do ' r.EntireRow.Hidden = False r.EntireRow.Sort Key1:=rcol, Order1:=xlDescending, Header:=xlNo For Each cell In r 'This is the line I get the error on. If InStr(1, sh.Cells(cell.Row, "H"), "Awaiting Scorecare", vbTextCompare) Or sh.Cells(cell.Row, "C") = ival Then cell.EntireRow.Hidden = True End If Next End With DoEvents For Each cell In r If cell.EntireRow.Hidden = False Then DoEvents ActiveWindow.ScrollRow = cell.Row DoEvents Application.ScreenUpdating = True DoEvents For i = 1 To 10000 ' 10000 Then ii = 0 Else ii = ii + 1 End If 'If ii > 10000 Then If Not IsEmpty(Range("J1")) Then Exit Sub DoEvents Next 'For i = 1 To 10000 DoEvents End If 'if cell.EntireRow.Hidden = False then Next 'For Each cell In r DoEvents Loop While IsEmpty(Range("J1")) End Sub ---------- FOLLOW-UP ---------- QUESTION: can you make this reference "H" a variable so I can make it different for each sheet. If InStr(1, sh.Cells(cell.Row, "H"), "Awaiting Scorecare", vbTextCompare) Or sh.Cells(cell.Row, "C") = ival Then cell.EntireRow.Hidden = True Also i would like to change the speed of the scrolling from a cell in the sheet is this possible. Alan ANSWER: Alan, You can define any sheet level attribute by adding to the case statement. As for the speed you can replace the 10000 in the upperbound of the loop structure to refer to a specific cell. You didn't say what cell or if it would be on each sheet or on only one sheet. I will assume only one sheet so I will use Sheet1, cell J2 to hold the "speed" value. icol is the variable to use instead of the hardcoded "H" note: the 10000 use in if ii > 10000 is immaterial. It can remain as it is. It has no effect on speed. Sub ScrollScores() Dim r As Range, cell As Range, ii As Long, i As Long Dim sh As Worksheet, v As Variant, idex As Long Dim vv As Variant, ival As Long Dim icol as Long, speed as Long v = Array("Net", "Gross", "Sheet1") idex = LBound(v) speed = worksheets("Sheet1").Range("J2").value if speed = 0 then speed = 10000 Do Set sh = Worksheets(v(idex)) ' loops through the specified sheets If idex = UBound(v) Then idex = LBound(v) Else idex = idex + 1 End If With sh Select Case .Name Case "Net" Set rcol = .Range("A2") ival = 1 icol = "H" Case "Gross" Set rcol = .Range("B2") ival = 4 icol = "H" Case "Sheet1" Set rcol = .Range("C2") ival = 1 icol = "H" Case Else Set rcol = .Range("D2") ival = 1 icol = "H" End Select .Activate .Range("J1").ClearContents .Range("A1").Select .Range("J1").Activate .Rows.EntireRow.Hidden = False Set r = .Range("A2", .Cells(.Rows.Count, "A").End(xlUp)) ' change B5 to the column you want to sort on, change xldescending to xlascending if that is ' what you want to do ' r.EntireRow.Hidden = False r.EntireRow.Sort Key1:=rcol, Order1:=xlDescending, Header:=xlNo For Each cell In r 'This is the line I get the error on. If InStr(1, sh.Cells(cell.Row, icol), "Awaiting Scorecare", vbTextCompare) Or sh.Cells(cell.Row, "C") = ival Then cell.EntireRow.Hidden = True End If Next End With DoEvents For Each cell In r If cell.EntireRow.Hidden = False Then DoEvents ActiveWindow.ScrollRow = cell.Row DoEvents Application.ScreenUpdating = True DoEvents For i = 1 To speed ' 10000 Then ii = 0 Else ii = ii + 1 End If 'If ii > 10000 Then If Not IsEmpty(Range("J1")) Then Exit Sub DoEvents Next 'For i = 1 To Speed DoEvents End If 'if cell.EntireRow.Hidden = False then Next 'For Each cell In r DoEvents Loop While IsEmpty(Range("J1")) End Sub -- Tom Ogilvy ---------- FOLLOW-UP ---------- QUESTION: when I run the code I get rcol error "variable not defined" and icol "type mismatch". The speed is ok. Can you help me please? that works really well. Just one more request. I would like two criteria¡¯s for hiding the rows. I currently have this: for each cell in r if instr(1,sh.Cells(cell.row,"H"),"Awaiting Scorecare",vbTextcompare) then cell.EntireRow.Hidden = True but would also like something to hide the rows if cells in column ¡°C¡± in sheet1 were not = to ¡°1¡±. I would also like ¡°1¡± to be a variable so it can be different for each sheet i.e. Sheet2 ¡°2¡±, sheet3 ¡°3¡±, very much like the sort solution you gave me. Alan QUESTION: in the auto scroll results macro if I add data to a hidden row using VLOOKUP, the range does not expand so it does not get sorted. It looks like when r is set it only counts the rows that are visible with data in them. Can you help please? ANSWER: Alan, This should fix the problem you describe. Sub ScrollScores() Dim r As Range, cell As Range, ii As Long, i As Long Dim sh as Worksheet, v as Variant, idex as Long v = Array("Net","Gross","Sheet1","Sheet2") idex = lbound(v) Do set sh = worksheets(v(idex)) ' loops through the specified sheets if idex = Ubound(v) then idex = lbound(v) else idex = idex + 1 end if With sh .Activate .Range("J1").ClearContents .Range("A1").Select .Range("J1").Activate .Rows.EntireRow.Hidden = False set r = .Range("A5",.cells(.rows.count,"A").End(xlup)) ' change B5 to the column you want to sort on, change xldescending to xlascending if that is ' what you want to do ' r.EntireRow.Hidden = False r.entirerow.sort Key1:=range("B5"), Order1:=xldescending, Header:=xlNo for each cell in r if instr(1,sh.Cells(cell.row,"H"),"Awaiting Scorecare",vbTextcompare) then cell.EntireRow.Hidden = True end if Next End with DoEvents For Each cell In r DoEvents ActiveWindow.ScrollRow = cell.Row DoEvents Application.ScreenUpdating = True DoEvents For i = 1 To 10000 ' 10000 Then ii = 0 Else ii = ii + 1 End If If Not IsEmpty(Range("J1")) Then Exit Sub DoEvents Next DoEvents Next DoEvents Loop While IsEmpty(Range("J1")) End Sub -- ---------- FOLLOW-UP ---------- QUESTION: nearly there, I have added Application.ScreenUpdating = False before.Rows.EntireRow.Hidden = False. This stop me seeing all the rows visible but it appears the line of code ActiveWindow.ScrollRow = cell.Row is scrolling the hidden rows which make it look like the last visible record is toggling with an empty row. ANSWER: Alan >make it look like the last visible record is toggling with an empty row I don't know what that means: But I suspect skipping over hidden rows is what you are after. I believe this will do it: Sub ScrollScores() Dim r As Range, cell As Range, ii As Long, i As Long Dim sh as Worksheet, v as Variant, idex as Long v = Array("Net","Gross","Sheet1","Sheet2") idex = lbound(v) Do set sh = worksheets(v(idex)) ' loops through the specified sheets if idex = Ubound(v) then idex = lbound(v) else idex = idex + 1 end if With sh .Activate .Range("J1").ClearContents .Range("A1").Select .Range("J1").Activate .Rows.EntireRow.Hidden = False set r = .Range("A5",.cells(.rows.count,"A").End(xlup)) ' change B5 to the column you want to sort on, change xldescending to xlascending if that is ' what you want to do ' r.EntireRow.Hidden = False r.entirerow.sort Key1:=range("B5"), Order1:=xldescending, Header:=xlNo for each cell in r if instr(1,sh.Cells(cell.row,"H"),"Awaiting Scorecare",vbTextcompare) then cell.EntireRow.Hidden = True end if Next End with DoEvents For Each cell In r if cell.EntireRow.Hidden = False then DoEvents ActiveWindow.ScrollRow = cell.Row DoEvents Application.ScreenUpdating = True DoEvents For i = 1 To 10000 ' 10000 Then ii = 0 Else ii = ii + 1 End If 'If ii > 10000 Then If Not IsEmpty(Range("J1")) Then Exit Sub DoEvents Next 'For i = 1 To 10000 DoEvents End if 'if cell.EntireRow.Hidden = False then Next 'For Each cell In r DoEvents Loop While IsEmpty(Range("J1")) End Sub ---------- FOLLOW-UP ---------- QUESTION: is it possible to have different keys to sort with for different sheets. i.e. r.entirerow.sort Key1:=range("B5"), Order1:=xldescending, Header:=xlNo for sheet ¡°net¡± And r.entirerow.sort Key1:=range("C5"), Order1:=xldescending, Header:=xlNo for sheet ¡°Gross¡±. Also for any other sheets that I add. Alan QUESTION: can you include a sort descending procedure every time the last row has scrolled as I am using VLOOKUP to keep the scores up to date. Can you help please? ANSWER: Alan seems sorting just before scrolling would be more up-to-date so I put it when the sheet is selected see comments above the sort command for options Sub ScrollScores() Dim r As Range, cell As Range, ii As Long, i As Long Dim sh as Worksheet, v as Variant, idex as Long v = Array("Net","Gross","Sheet1","Sheet2") idex = lbound(v) Do set sh = worksheets(v(idex)) ' loops through the specified sheets if idex = Ubound(v) then idex = lbound(v) else idex = idex + 1 end if With sh .Activate .Range("J1").ClearContents .Range("A1").Select .Range("J1").Activate set r = .Range("A5",.cells(.rows.count,"A").End(xlup)) ' change B5 to the column you want to sort on, change xldescending to xlascending if that is ' what you want to do r.entirerow.sort Key1:=range("B5"), Order1:=xldescending, Header:=xlNo End with DoEvents For Each cell In r DoEvents ActiveWindow.ScrollRow = cell.Row DoEvents Application.ScreenUpdating = True DoEvents For i = 1 To 10000 ' DoEvents If ii > 10000 Then ii = 0 Else ii = ii + 1 End If If Not IsEmpty(Range("J1")) Then Exit Sub DoEvents Next DoEvents Next DoEvents Loop While IsEmpty(Range("J1")) End Sub ---------- FOLLOW-UP ---------- QUESTION: the spreadsheet works great. Is it possible to include some code that hides a row that contains a specific text in column ¡°H¡±? The text comes from this formula =IF(G2=0,"Awaiting Scorecard",G2) And unhide when it does not contain the text. Or maybe whether the formula argument is met or not met. ANSWER: Alan Sub ScrollScores() Dim r As Range, cell As Range, ii As Long, i As Long Dim sh as Worksheet, v as Variant, idex as Long v = Array("Net","Gross","Sheet1","Sheet2") idex = lbound(v) Do set sh = worksheets(v(idex)) ' loops through the specified sheets if idex = Ubound(v) then idex = lbound(v) else idex = idex + 1 end if With sh .Activate .Range("J1").ClearContents .Range("A1").Select .Range("J1").Activate set r = .Range("A5",.cells(.rows.count,"A").End(xlup)) ' change B5 to the column you want to sort on, change xldescending to xlascending if that is ' what you want to do r.entirerow.sort Key1:=range("B5"), Order1:=xldescending, Header:=xlNo r.EntireRow.Hidden = False for each cell in r if instr(1,sh.Cells(cell.row,"H"),"Awaiting Scorecare",vbTextcompare) then cell.EntireRow.Hidden = True end if Next End with DoEvents For Each cell In r DoEvents ActiveWindow.ScrollRow = cell.Row DoEvents Application.ScreenUpdating = True DoEvents For i = 1 To 10000 ' 10000 Then ii = 0 Else ii = ii + 1 End If If Not IsEmpty(Range("J1")) Then Exit Sub DoEvents Next DoEvents Next DoEvents Loop While IsEmpty(Range("J1")) End Sub ---------- FOLLOW-UP ---------- QUESTION: , When the macro sorts the rows that are hidden they do not get sorted and the scrolling behaves peculiar. The sort column is numerical. I need all rows in the range to be unhidden before the sort and then hidden using the criteria ¡°awaiting scorecard¡± after the sort so they are not part of the scrolling procedure. Regards Alan QUESTION: I have a golf society competition worksheet which I project (display). At present I manually scroll down the worksheet to display results of the competition to the society. I would welcome help in writing a macro that would automatically start at the top and then scroll down the worksheet to the last row and then restart scrolling from the top again - repeating until I cancel the macro. I would also like to freeze the top three scores so they are seen at all times. Can you help? ANSWER: Alan, You can set Freeze Frame manually. Assume your data headers are in row 1 and the first three best scores are in order in rows 2, 3 and 4. Select row 5 and in Excel 2007 and later, go to the view tab and select Freeze panes and in the dropdown select the first choice "Freeze Panes". in Excel 2003 and earlier, freeze frames is found in the windows menu. this will freeze the top three scores. Now assume the remainder of the players are listed in rows 5 to 50. Also assume cell J1 on that sheet is empty and available for use to stop the macro. After you start the macro, the macro runs until J1 is no longer empty. So typing anyting in J1 will stop the macro. Note that while the macro is running, tyou will probably have trouble doing anything else in that instance of excel. You can run this macro Sub ScrollScores() Dim r As Range, cell As Range, ii As Long, i As Long Range("J1").ClearContents Range("J1").Activate Set r = Range("A5:A50") bStop = False Do DoEvents For Each cell In r DoEvents ActiveWindow.ScrollRow = cell.Row DoEvents Application.ScreenUpdating = True DoEvents For i = 1 To 10000 ' 10000 Then ii = 0 Else ii = ii + 1 End If If Not IsEmpty(Range("J1")) Then Exit Sub DoEvents Next DoEvents Next DoEvents Loop While IsEmpty(Range("J1")) And bStop = False End Sub ---------- FOLLOW-UP ---------- QUESTION: , Just a few questions. I am running this macro with 2 sheets Gross and Net. After the last row has scrolled on gross sheet I would like to display the net sheet and visa versa. I would also like the range to be variable. Can you help please. I have resent this question as I realised I called you Bob and not Tom. Many apologies for that. ANSWER: Alan, you would have to be clearer on what you mean by a dynamic range. I have included one approach in the code below. The code is untested, so it may require some tweaking on your part. Sub ScrollScores() Dim r As Range, cell As Range, ii As Long, i As Long bStop = False Do if lcase(activesheet.name) = "net" then With worksheets("gross") .Activate .Range("J1").ClearContents .Range("A1").Select .Range("J1").Activate set r = .Range("A5",.cells(.rows.count,"A").End(xlup)) End with else With worksheets("net") .Activate .Range("J1").ClearContents .Range("A1").Select .Range("J1").Activate set r = .Range("A5",.cells(.rows.count,"A").End(xlup)) end with End if DoEvents For Each cell In r DoEvents ActiveWindow.ScrollRow = cell.Row DoEvents Application.ScreenUpdating = True DoEvents For i = 1 To 10000 ' 10000 Then ii = 0 Else ii = ii + 1 End If If Not IsEmpty(Range("J1")) Then Exit Sub DoEvents Next DoEvents Next DoEvents Loop While IsEmpty(Range("J1")) And bStop = False End Sub ---------- FOLLOW-UP ---------- QUESTION: the code worked fine and your range selection was just what I wanted. If possible can you tell me how to modify the code to increase the number of sheets to scroll through? Maybe I could then modify the code myself and learn a little? I would also like code that worked on one sheet only?

• Answer:

  Alan, My error. Changed my mind on implementation and didn't get everything revised. Sub ScrollScores() Dim r As Range, cell As Range, ii As Long, i As Long Dim sh As Worksheet, v As Variant, idex As Long Dim vv As Variant, ival As Long Dim icol as Variant, speed as Long v = Array("Net", "Gross", "Sheet1") idex = LBound(v) speed = worksheets("Sheet1").Range("J2").value if speed = 0 then speed = 10000 Do Set sh = Worksheets(v(idex)) ' loops through the specified sheets If idex = UBound(v) Then idex = LBound(v) Else idex = idex + 1 End If With sh Select Case .Name Case "Net" Set rcol = .Range("A2") ival = 1 icol = "H" Case "Gross" Set rcol = .Range("B2") ival = 4 icol = "H" Case "Sheet1" Set rcol = .Range("C2") ival = 1 icol = "H" Case Else Set rcol = .Range("D2") ival = 1 icol = "H" End Select .Activate .Range("J1").ClearContents .Range("A1").Select .Range("J1").Activate .Rows.EntireRow.Hidden = False Set r = .Range("A2", .Cells(.Rows.Count, "A").End(xlUp)) ' change B5 to the column you want to sort on, change xldescending to xlascending if that is ' what you want to do ' r.EntireRow.Hidden = False r.EntireRow.Sort Key1:=rcol, Order1:=xlDescending, Header:=xlNo For Each cell In r 'This is the line I get the error on. If InStr(1, sh.Cells(cell.Row, icol), "Awaiting Scorecare", vbTextCompare) Or sh.Cells(cell.Row, "C") = ival Then cell.EntireRow.Hidden = True End If Next End With DoEvents For Each cell In r If cell.EntireRow.Hidden = False Then DoEvents ActiveWindow.ScrollRow = cell.Row DoEvents Application.ScreenUpdating = True DoEvents For i = 1 To speed ' 10000 Then ii = 0 Else ii = ii + 1 End If 'If ii > 10000 Then If Not IsEmpty(Range("J1")) Then Exit Sub DoEvents Next 'For i = 1 To Speed DoEvents End If 'if cell.EntireRow.Hidden = False then Next 'For Each cell In r DoEvents Loop While IsEmpty(Range("J1")) End Sub should clear up that error. Alan Is it an Or or an And condition -- OR -- if instr(1,sh.Cells(cell.row,"H"),"Awaiting Scorecare",vbTextcompare) Or sh.Cells(cell.row,"C") = vv(i) then -- AND -- if instr(1,sh.Cells(cell.row,"H"),"Awaiting Scorecare",vbTextcompare) And sh.Cells(cell.row,"C")) = vv(i) then vv would be an array similar to the sort Dim vv as Variant vv = Array(1, 4, 1, 1) for example Alan, certainly you can use a variable that is determined by furnishing a list. Sub ScrollScores() Dim r As Range, cell As Range, ii As Long, i As Long Dim sh as Worksheet, v as Variant, idex as Long v = Array("Net","Gross","Sheet1","Sheet2","Sheet3","Sheet5") idex = lbound(v) Do set sh = worksheets(v(idex)) ' loops through the specified sheets if idex = Ubound(v) then idex = lbound(v) else idex = idex + 1 end if With sh Select Case .Name Case "Net" set rcol = .Range("B5") Case "Gross" set rcol = .Range("C5") Case "Sheet2" set rcol = .Range("D5") Case Else set rcol = .Range("A5") end Select .Activate .Range("J1").ClearContents .Range("A1").Select .Range("J1").Activate .Rows.EntireRow.Hidden = False set r = .Range("A5",.cells(.rows.count,"A").End(xlup)) ' change B5 to the column you want to sort on, change xldescending to xlascending if that is ' what you want to do ' r.EntireRow.Hidden = False r.entirerow.sort Key1:=rcol, Order1:=xldescending, Header:=xlNo for each cell in r if instr(1,sh.Cells(cell.row,"H"),"Awaiting Scorecare",vbTextcompare) then cell.EntireRow.Hidden = True end if Next End with DoEvents For Each cell In r if cell.EntireRow.Hidden = False then DoEvents ActiveWindow.ScrollRow = cell.Row DoEvents Application.ScreenUpdating = True DoEvents For i = 1 To 10000 ' 10000 Then ii = 0 Else ii = ii + 1 End If 'If ii > 10000 Then If Not IsEmpty(Range("J1")) Then Exit Sub DoEvents Next 'For i = 1 To 10000 DoEvents End if 'if cell.EntireRow.Hidden = False then Next 'For Each cell In r DoEvents Loop While IsEmpty(Range("J1")) End Sub Alan I moved the appropriate line of code Sub ScrollScores() Dim r As Range, cell As Range, ii As Long, i As Long Dim sh as Worksheet, v as Variant, idex as Long v = Array("Net","Gross","Sheet1","Sheet2") idex = lbound(v) Do set sh = worksheets(v(idex)) ' loops through the specified sheets if idex = Ubound(v) then idex = lbound(v) else idex = idex + 1 end if With sh .Activate .Range("J1").ClearContents .Range("A1").Select .Range("J1").Activate set r = .Range("A5",.cells(.rows.count,"A").End(xlup)) ' change B5 to the column you want to sort on, change xldescending to xlascending if that is ' what you want to do r.EntireRow.Hidden = False r.entirerow.sort Key1:=range("B5"), Order1:=xldescending, Header:=xlNo for each cell in r if instr(1,sh.Cells(cell.row,"H"),"Awaiting Scorecare",vbTextcompare) then cell.EntireRow.Hidden = True end if Next End with DoEvents For Each cell In r DoEvents ActiveWindow.ScrollRow = cell.Row DoEvents Application.ScreenUpdating = True DoEvents For i = 1 To 10000 ' 10000 Then ii = 0 Else ii = ii + 1 End If If Not IsEmpty(Range("J1")) Then Exit Sub DoEvents Next DoEvents Next DoEvents Loop While IsEmpty(Range("J1")) End Sub Alan, Sub ScrollScores() Dim r As Range, cell As Range, ii As Long, i As Long Dim sh as Worksheet, v as Variant, idex as Long v = Array("Net","Gross","Sheet1","Sheet2") idex = lbound(v) Do set sh = worksheets(v(idex)) ' loops through the specified sheets if idex = Ubound(v) then idex = lbound(v) else idex = idex + 1 end if With sh .Activate .Range("J1").ClearContents .Range("A1").Select .Range("J1").Activate set r = .Range("A5",.cells(.rows.count,"A").End(xlup)) End with DoEvents For Each cell In r DoEvents ActiveWindow.ScrollRow = cell.Row DoEvents Application.ScreenUpdating = True DoEvents For i = 1 To 10000 ' DoEvents If ii > 10000 Then ii = 0 Else ii = ii + 1 End If If Not IsEmpty(Range("J1")) Then Exit Sub DoEvents Next DoEvents Next DoEvents Loop While IsEmpty(Range("J1")) End Sub code for a single sheet would just mean to specify only one sheet in the array: v = Array("Gross")