Help with a macro Hi, the following macro was generated by one of the experts in

Question

Help with a macro

Hi, the following macro was generated by one of the experts in this forum:

Sub TestMacro()
    Dim sh As Worksheet
    ActiveSheet.Copy After:=ActiveSheet
    Set sh = ActiveSheet
    sh.Name = "Exported cities"
    sh.Range("R:R").Insert
    sh.Range("R1").Value = "Randomize"
    sh.Range("R2:R" & sh.Cells(sh.Rows.Count, "Q").End(xlUp).Row).Formula = "=RAND()"
    With sh.Sort
        .SortFields.Clear
        .SortFields.Add Key:=Range("R2"), SortOn:=xlSortOnValues, Order:=xlAscending
        .SetRange sh.UsedRange
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .Apply
    End With
    With sh.Sort
        .SortFields.Clear
        .SortFields.Add Key:=Range("Q2"), SortOn:=xlSortOnValues, Order:=xlAscending
        .SetRange sh.UsedRange
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .Apply
    End With
   
   .Range("R2:R" & sh.Cells(sh.Rows.Count, "Q").End(xlUp).Row).FormulaR1C1 = _
        "=IF(COUNTIF(R1C17:RC[-1],RC[-1])<=((COUNTIF(C[-1],RC[-1])+2)/2),""Keep"","""")"

    Columns("R:R").AutoFilter Field:=1, Criteria1:="="
    sh.UsedRange.Offset(1).SpecialCells(xlCellTypeVisible).EntireRow.Delete
    sh.ShowAllData
    Columns("R:R").Delete
End Sub

The code works fine to pick 50% randomm and to include any city even if it appears for once. Onee drawback, it adds an additional

Explanation / Answer

Try replacing the

.Range("R2:R" & sh.Cells(sh.Rows.Count, "Q").End(xlUp).Row).FormulaR1C1 = _
        "=IF(COUNTIF(R1C17:RC[-1],RC[-1])<=((COUNTIF(C[-1],RC[-1])+2)/2),""Keep"","""")"

statement with this. I've added needed With...End With to it along with the change in the formula. Rather a brute force kind of approach, select MAXIMUM of either 1 or the [result of division]-1. For cities with just 1 entry, the result-1 would be zero, so this adds that back in.

With your (thank you) test data I got:::

Atlanta once

Chicago 4 times (9 times on original sheet)

Cincinnati 3 times (6 times on originaal sheet)

Knoxville 2 times (4 times on original sheet)

Lincoln 2 times (4 times on original sheet)

St Paul 2 times (4 times on original sheet)

Tallahassee 4 times (8 times on original sheet)

and several others just once (including the one with the empty city name)

With sh
    .Range("R2:R" & sh.Cells(sh.Row?s.Count, "Q").End(xlUp).Row).FormmulaR1C1 = _
        "=IF(COUNTIF(R1C17:RC[-1],RC[-1])<=MAX(1,((COUNTIF(C[-1],RC[-1])+2)/2-1)),""Keep"","""")"

End With

Related Questions

Navigate

• Browse (All)
• Browse H
• Subjects

Integrity-first tutoring: explanations and feedback only — we do not complete graded work. Learn more.