Random selections

[Kim]

I am helping a user who has a Workbook which contains multiple worksheets of
demographic information from the state. Each worksheet is from a different
county. They are wanting to select a random number of records from each
county (worksheet) for a mailing.

I tried the rand() command but that didn't do what we needed. I then
selected all worksheets and then selected every fifth record (holding ctrl)
but wasn't able to copy to another worksheet. So I named that range, thinking
I could merge into Word or Access selecting the range, but the named range
didn't appear when I tried to import.

Any ideas?

 

[Bernie Deitrick]

Try running the macro below while the workbook with the data is active. Change the line

Frac = 0.05

to whatever percent (as a decimal) that you want to select (e.g., 0.2 = 20%)

HTH,
Bernie
MS Excel MVP


Sub ConsolidateRandomSelectionFromSheetsIntoDataBase()

With Application
.DisplayAlerts = False
.EnableEvents = False
.ScreenUpdating = False
End With

Dim i As Integer
Dim myDB As Worksheet
Dim Frac As Double

Frac = 0.05

Set myDB = Worksheets.Add(Before:=Worksheets(1))
myDB.Name = "Random Selection"

Worksheets(2).Cells.Copy Worksheets(1).Cells

With Worksheets(1)
.Cells(1, 1).EntireColumn.Insert
.Cells(1, 1).Value = "County"
Intersect(.Range("A2:A" & .Rows.Count), _
.UsedRange).Value = Worksheets(2).Name
End With

For i = 3 To Worksheets.Count
With Worksheets(1)
myRow = .Cells(Rows.Count, 1).End(xlUp).Row + 1
Worksheets(i).Cells(1, 1).CurrentRegion.Offset(1) _
.Copy Worksheets(1).Cells(myRow, 2)
Intersect(.Range("A" & myRow & ":A" & .Rows.Count), _
.UsedRange).Value = Worksheets(i).Name
End With
Next i

With Worksheets(1)
.Cells(1, 1).EntireColumn.Insert
.Cells(1, 1).Value = "Select"
Intersect(.Range("A2:A" & .Rows.Count), _
.UsedRange).Formula = "=RAND()<" & Format(Frac, "0.000")
Application.CalculateFull
.Range("A:A").Value = .Range("A:A").Value
.Cells.Sort Key1:=.Range("A2"), Order1:=xlDescending, Header:=xlYes
Set myR = .Columns("A:A").Find(What:="FALSE", After:=.Range("A1"))
.Range(myR, myR.End(xlDown)).EntireRow.Delete
.Range("A:A").Delete
End With

With Application
.DisplayAlerts = True
.EnableEvents = True
.ScreenUpdating = True
End With

End Sub

 

[Bernie Deitrick]

I should have stated my assumptions: that the sheet name is the county name, and the data is in a
table with the headers in Row1, and data starting in row 2, cell A2.

HTH,
Bernie
MS Excel MVP