CODEWITHSUNDEEP
vbaexcelfor-loop
Anusha
Anusha

Reputation: 1726

Loop that returns to starting point for selecting Nth row

I want to select M companies from a sample of S companies and doing this starting from a random number selected between 1 and S and selecting every Nth company.

To get the sample of M, I want the loop to come back to starting point for selecting the companies. Here xInterval is N, lrowCount is S and M is N/S. I tried using offset and changing indices of for loop.

Can anyone suggest a solution?

Sub circularSystematicSampling()

Dim rng As Range
Dim InputRng As Range
Dim OutRng As Range
Dim xInterval As Integer
Dim lrowCount As Integer
Dim endPoint As Integer
Dim circular As Boolean


xTitleId = "Testing"

Set InputRng = ActiveSheet.UsedRange

    Set InputRng = InputRng.Offset(1).Resize(InputRng.Rows.Count - 1)

    InputRng.Select

xInterval = Application.InputBox("Number of companies is" & " " & InputRng.Rows.Count & vbCrLf & " Enter row interval", xTitleId, Type:=1)
lrowCount = ActiveSheet.UsedRange.Rows.Count

randomStart = Int((lrowCount - 1 + 1) * Rnd + 1)
endPoint = Int(lrowCount + randomStart)
endPoint2 = Int(randomStart - 1)


If endPoint > lrowCount Then
    circular = True
End If

For i = (1 + randomStart) To endPoint Step xInterval
    Set rng = InputRng.Cells(i, 1)

    If circular Then
    ActiveCell.Offset(1, 0).Select
    End If


    If OutRng Is Nothing Then
        Set OutRng = rng
    Else
        Set OutRng = Application.Union(OutRng, rng)
    End If

Next
OutRng.EntireRow.Select

With Selection.Interior
        .PatternColorIndex = xlAutomatic
        .Color = 65535
        .TintAndShade = 0
        .PatternTintAndShade = 0
    End With
End Sub

How do I modify this loop to come back to starting point when selecting xInterval row? Thanks.

Edit: Another approach while circular true 

If circular Then
For j = 1 To endPoint2 Step xInterval ' ActiveCell.Offset(1, 0).Select
Set rng2 = InputRng.Cells(j, endPoint2)
End If

If OutRng Is Nothing Then
    Set OutRng = rng
Else
    Set OutRng = Application.Union(OutRng, rng, rng2)
End If

Another possibility using DO while 

For i = (1 + randomStart) To endPoint Step xInterval
    Do While Not IsEmpty(ActiveCell)
    Set rng = InputRng.Cells(i, endPoint)

Do While IsEmpty(ActiveCell)
ActiveCell.Offset(1, 0).Select
For j = 1 To endPoint2 Step xInterval
Set rng2 = InputRng.Cells(j, endPoint2)
End If

If OutRng Is Nothing Then
    Set OutRng = rng
Else
    Set OutRng = Application.Union(OutRng, rng, rng2)
End If

Upvotes: 1

Views: 172

Answers (1)

Robin Mackenzie
Robin Mackenzie

Reputation: 19289

If you just loop over the actual rows from 1 to S then you can use the Mod function to send the loop back 'to the top':

For lngCounter = 1 To lngRowCount Step lngRowInterval
    lngTargetRow = (lngRandRowStart + lngCounter) Mod lngRowCount
    strOutRanges = strOutRanges & rngData.Cells(lngTargetRow + 1, 1).Address & ","
Next lngCounter

I had an issue with your method of Unioning the Ranges so am just building a list of cell addresses to format in the loop.

Full example:

Option Explicit

Sub circularSystematicSampling()

    Dim rngData As Range
    Dim lngRowCount As Long
    Dim lngRowInterval As Long
    Dim lngRandRowStart As Long
    Dim lngCounter As Long
    Dim lngTargetRow As Long
    Dim strOutRanges As String
    Dim rngOut As Range

    ' set range to iterate
    Set rngData = ThisWorkbook.Worksheets("Sheet1").UsedRange
    ' drop header
    Set rngData = rngData.Offset(1).Resize(rngData.Rows.Count - 1)
    ' get total rows
    lngRowCount = rngData.Rows.Count
    ' set an interval
    lngRowInterval = Application.InputBox("Enter row interval", "Test", 1)
    ' set a random start point
    lngRandRowStart = Int(rngData.Rows.Count * Rnd + 1)

    ' iterate rows - calculate offset in loop
    strOutRanges = ""
    For lngCounter = 1 To lngRowCount Step lngRowInterval
        lngTargetRow = (lngRandRowStart + lngCounter) Mod lngRowCount
        strOutRanges = strOutRanges & rngData.Cells(lngTargetRow + 1, 1).Address & ","
    Next lngCounter
    'drop trailing comma
    strOutRanges = Left(strOutRanges, Len(strOutRanges) - 1)

    ' create range with string of addresses
    Set rngOut = Range(strOutRanges)
    Debug.Print rngOut.Address

    With rngOut.EntireRow.Interior
        .PatternColorIndex = xlAutomatic
        .Color = 65535
        .TintAndShade = 0
        .PatternTintAndShade = 0
    End With

End Sub

Upvotes: 1

Related Questions