Loop code

redspanna

Well-known Member
Joined
Jul 27, 2005
Messages
1,602
Office Version
  1. 365
Platform
  1. Windows
Hi All

I have following code that works fine..
Code:
Sub Report_Data()
Dim NextRow As Long
Dim rng As Range
Set rng = Sheets("Copied Data").Range("L" & Rows.Count).End(xlUp).Resize(1, 8)
Application.ScreenUpdating = False
Sheets("copied data").Select
Range("A1:BB50").Select
Selection.ClearContents
Sheets("database").Select
Range("A1").Select
Selection.AutoFilter
ActiveSheet.Range("$A$1:$AW$7890").AutoFilter Field:=49, Criteria1:="[COLOR="#FF0000"].Sheets("Pivots").Range("E4")[/COLOR]

'copy filtered data
Cells.Select
Selection.Copy
Sheets("copied data").Select
Cells.Select
Range("a1").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
Range("C2:C28").Select
Selection.Replace What:="0", Replacement:="", LookAt:=xlPart, _
        SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
        ReplaceFormat:=False

With Sheets("Copied Data")
    NextRow = .Cells(Rows.Count, "L").End(xlUp).Row + 1
    .Range("L" & NextRow).Formula = "=SUM(L2:L" & NextRow - 1 & ")/('Report data'!$D$3-(COUNTIF(L2:L" & NextRow - 1 & ",""NA"")))"
    .Range("L" & NextRow & ":AR" & NextRow).FillRight

Sheets("Copied Data").Range("L" & Rows.Count).End(xlUp).Resize(1, 33).Copy
Sheets("Report Data")[COLOR="#FF0000"].Range("F2")[/COLOR].PasteSpecial Paste:=xlValues, Transpose:=True

End With
End Sub

I would like it to loop until no values in the Sheet 'Pivot' Range E4:E15 have been found

Also as each loop is completed the pasted data is pasted into a fresh cell...

So on first running the cell value from Pivot Sheet cell E4 is used for the Filter and the eventual copied data will be pasted into Report Data sheet cell F2 as above in RED
on next run the cell value from Pivot Sheet cell E5 is used for the Filter and the eventual copied data will be pasted into Report Data sheet cell G2
on next run the cell value from Pivot Sheet cell E6 is used for the Filter and the eventual copied data will be pasted into Report Data sheet cell H2
on next run the cell value from Pivot Sheet cell E7 is used for the Filter and the eventual copied data will be pasted into Report Data sheet cell I2
and so on until NO values are found in range E4:E15 of the Pivot sheet

Hope this makes sense and many thanks in advance
 

Excel Facts

Is there a shortcut key for strikethrough?
Ctrl+S is used for Save. Ctrl+5 is used for Strikethrough. Why Ctrl+5? When you use hashmarks to count |||| is 4, strike through to mean 5.
Hey Red,

Theres alot that could be done to improve this sub, steering away from the many select statements etc, but i'm a bit rushed for time at the mo.

a simple for loop should be enough to cycle through the cells, both for the filter and the paste location.

Code:
Sub Report_Data()

    Dim NextRow As Long
    Dim rng As Range
    Dim i As Byte
    
    Set rng = Sheets("Copied Data").Range("L" & Rows.Count).End(xlUp).Resize(1, 8)
        
        Application.ScreenUpdating = False

        Sheets("copied data").Select
        
        Range("A1:BB50").Select
        
        Selection.ClearContents
            
        For i = 4 To 15 'Loop starts here
        
            Sheets("database").Select
            
            Range("A1").Select
            
            Selection.AutoFilter
            
            ActiveSheet.Range("$A$1:$AW$7890").AutoFilter Field:=49, Criteria1:=.Sheets("Pivots").Cells(5, i) 'uses i value to reference the row
            
            'copy filtered data
            Cells.Select
            
            Selection.Copy
            
            Sheets("copied data").Select
            
            Cells.Select
            
            Range("a1").Select
            
            Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
                    :=False, Transpose:=False
            
            Range("C2:C28").Select
            
            Selection.Replace What:="0", Replacement:="", LookAt:=xlPart, _
                    SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
                    ReplaceFormat:=False
            
            With Sheets("Copied Data")
                NextRow = .Cells(Rows.Count, "L").End(xlUp).Row + 1
                .Range("L" & NextRow).Formula = "=SUM(L2:L" & NextRow - 1 & ")/('Report data'!$D$3-(COUNTIF(L2:L" & NextRow - 1 & ",""NA"")))"
                .Range("L" & NextRow & ":AR" & NextRow).FillRight
            
                Sheets("Copied Data").Range("L" & Rows.Count).End(xlUp).Resize(1, 33).Copy
                Sheets("Report Data").Cells(i + 2, 2).PasteSpecial Paste:=xlValues, Transpose:=True 'uses i+2 to reference the column. These increase as the loop progresses
            
            End With
            
        Next i
        
End Sub

good luck!
 
Upvote 0

Forum statistics

Threads
1,213,484
Messages
6,113,923
Members
448,533
Latest member
thietbibeboiwasaco

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top