Macro to copy data based on criteria - Percentage - For sampling

[shan]

Hello Everyone,

I request your help on Macro to copy data from one sheet to another sheet based on percentage criteria. The purpose of this is Sampling.

Description:

I have a file which has 3 columns Col1-Sr No., Col2-TYPE, Col3-Data.
In the file there are 3 Types - C,R and T ( featuring under TYPE column). I want do extrat a samples for these TYPEs.

I want,

8% samples for C - if in decimal round-off on higher side
10% samples for R - if in decimal round-off on higher side
15% samples for T - if in decimal round-off on higher side

... Also I have attached a Excel for better understanding

Hope I am able to explain you properly...

Thanks
Regards
Shan

[excelliot]

do you want to add data in existing data in sheets C, R, T or replace?

do you want to have duplicate records there or only unique one?

how you want to trigger action? thru input box or any other method?

Cheers!!
www.excelliot.com

[shan]

Thank you for your reply

Answer to your queries

do you want to add data in existing data in sheets C, R, T or replace?
Ans- In sheets C,R,T ... each time we will be using a new file ... hence sheet C,R,T will not have any data

do you want to have duplicate records there or only unique one?
Ans- only unique records

how you want to trigger action? thru input box or any other method?
Ans- Sorry but I did not get this

[excelliot]

Shan,

Check this attachment.. Click on blue button to run macro..

1st you will be prompted for entering type, you need to enter either of C, R , T..

After that you will be prompted for entering %, just enter number & press ok..

A new sheet will be generated by Input Given.. You can repeat this steps to get output for other Type.

Cheers!!
www.excelliot.com

[shan]

Thank you so much Sir.

This is working fine. But I need to hardcode this into the code... I do not want user to put any % or Type Value...
Also one thing sir.. code is considering Header as a one row... which should not be the case.

[excelliot]

Ok, check this..

[shan]

Thank you so much Sir.
It is working fine ... only one thing

Now I have change % to C=90, R=55 and T=80 ... but one row is capture less for C and R.

The total row count for C is 7 so =7*.90=6.3 .... we need to round-off to higher side i.e. 7 .... hence 7 rows should have copied for C instead of 6 rows.

The total row count for R is 7 so =8*.55=4.4 .... we need to round-off to higher side i.e. 5 .... hence 5 rows should have copied for C instead of 4 rows.

The rows for T is captured correctly as the full number came after calculation i.e. =5*.80=4 .... hence 4 rows correctly ccopied

[shan]

Hello Sir,

I am sorry ... forgot to incorporate one more criteria ...

If values under DATA column are repeated for same TYPE then code should pick up only one value..

e.g.

for TYPE C ... we need to extract 3 rows out of 7 rows ... if for first two rows value under DATA is same then code should the this only one row out of these two rows and remaining 2 rows which are unique based on DATA.

tx

[excelliot]

this covers all your requirements:

You can mark thread as completed & also add Reputation if it is helpful..


Cheers!!
www.excelliot.com

[shan]

Thank you Sir..

How do I use Roundup function in below code created by you...

wks.Activate
lr = Cells(Rows.Count, 1).End(xlUp).Row
lr2 = Application.WorksheetFunction.Max(1, Round((lr - 1) * fPc / 100, 0)) + 2
Range("A" & lr2 & ":A" & lr).EntireRow.Delete

[shan]

Once this is done I will mark the thread as Complete

[excelliot]

change this line buddy
lr2 = Application.WorksheetFunction.Max(1, Round((lr - 1) * fPc / 100, 0)) + 2

to


lr2 = RoundUp((lr - 1) * fPc / 100, 1) + 2

Cheers!!
excelliot.com

[shan]

Sir,

I tried this is giving me error as Compile Error... Sub or Function not defined

[shan]

I have run below code its working only for "R" but not running for "C" and "T"

lr2 = Application.WorksheetFunction.RoundUp((lr - 1) * fPc / 100, 0) + 2

[excelliot]

my bad..try this


lr2 = Application.WorksheetFunction.RoundUp((lr - 1) * fPc / 100, 1) + 2

Cheers!!

[shan]

Sorry Sir,
But code is not rounding up the number. Hence I have changed the code as below but the same is excepting only for "R" and not for "C" and "T".

lr2 = Application.WorksheetFunction.RoundUp((lr - 1) * fPc / 100, 0) + 2

[shan]

Sorry Sir... Its working fine with the above code...
Thank you so much for your help
I am marking this thread as Completed

[excelliot]

Great!!

[shan]

Sorry to bother you again Sir!!!

Whichever row we are coping and pasting on "C", "R" and "T" sheets... can it will be randomly picked up based on percentage
Currently First row is getting picked up by this code..

[excelliot]

yes..any thing else you need to customise?

[shan]

Sir... can you please help me with these changes... instead of first rows i want to pickup any row...

[excelliot]

Ok, try this code:


Sub sampling()
Dim myCell As Range
Dim wks As Worksheet
Dim DataBaseWks As Worksheet
Dim ListRange As Range
Dim dummyRng As Range
Dim myDatabase As Range
Dim TempWks As Worksheet
Dim rsp As Integer
Dim i As Long
Dim fCriterion As String, fPc As Integer
Dim lr As Integer, lr2 As Integer

Const TopLeftCellOfDataBase As String = "A1"
Const KeyColumn As String = "B"


Set DataBaseWks = Worksheets("raw data")
i = DataBaseWks.Range(TopLeftCellOfDataBase).Row - 1

'fCriterion = Application.InputBox("Enter Trype value for filtering data")
'fPc = Application.InputBox("Enter % in numbers")


Application.DisplayAlerts = False
Set TempWks = Worksheets.Add


With DataBaseWks
Set dummyRng = .UsedRange
Set myDatabase = .Range(TopLeftCellOfDataBase, _
.Cells.SpecialCells(xlCellTypeLastCell))
End With


With DataBaseWks
Intersect(myDatabase, .Columns(KeyColumn)).AdvancedFilter _
Action:=xlFilterCopy, _
CopyToRange:=TempWks.Range("A1"), _
Unique:=True


TempWks.Range("D1").Value = _
.Cells(.Range(TopLeftCellOfDataBase).Row, KeyColumn).Value
End With


With TempWks
Set ListRange = .Range("A2", .Cells(.Rows.Count, "A").End(xlUp))
End With


With ListRange
.Sort Key1:=.Cells(1), Order1:=xlAscending, _
Header:=xlNo, OrderCustom:=1, _
MatchCase:=False, Orientation:=xlTopToBottom
End With


'For Each myCell In ListRange.Cells
For n = 1 To 3
If n = 1 Then
fCriterion = "C": fPc = 90 '<======================
ElseIf n = 2 Then
fCriterion = "R": fPc = 55
Else
fCriterion = "T": fPc = 80
End If

If WksExists(fCriterion) = False Then
Set wks = Sheets.Add
On Error Resume Next
wks.Name = fCriterion 'myCell.Value
If Err.Number <> 0 Then
MsgBox "Please rename: " & wks.Name
Err.Clear

End If
On Error GoTo 0
wks.Move After:=Sheets(Sheets.Count)
Else
Set wks = Worksheets(fCriterion)
wks.Cells.Clear
End If


If rsp = 6 Then
DataBaseWks.Rows("1:" & i).Copy Destination:=wks.Range("A1")
End If

TempWks.Range("D2").Value = "=" & Chr(34) & "=" & fCriterion & Chr(34)


If rsp = 6 Then
myDatabase.AdvancedFilter _
Action:=xlFilterCopy, _
CriteriaRange:=TempWks.Range("D1:D2"), _
CopyToRange:=wks.Range("A1").Offset(i, 0), _
Unique:=True
Else
myDatabase.AdvancedFilter _
Action:=xlFilterCopy, _
CriteriaRange:=TempWks.Range("D1:D2"), _
CopyToRange:=wks.Range("A1"), _
Unique:=True
'Columns("D:D").ColumnWidth = 25
End If


wks.Activate

'remove duplicate
lr3 = Cells(Rows.Count, 1).End(xlUp).Row
For i = lr3 To 2 Step -1
If Application.WorksheetFunction.CountIf(Range("C2:C" & lr3), Cells(i, 3)) > 1 Then
Cells(i, 3).EntireRow.Delete
End If
Next i

lr = Cells(Rows.Count, 1).End(xlUp).Row
'lr2 = Application.WorksheetFunction.Max(1, Round((lr - 1) * fPc / 100, 0)) + 2
lr2 = Application.WorksheetFunction.RoundUp((lr - 1) * fPc / 100, 1) + 2

'Range("A" & lr2 & ":A" & lr).EntireRow.Delete
If lr2 < lr Then
For i = 1 To (lr - lr2)
Range("A" & Int((lr - 1) * Rnd + 2)).EntireRow.Delete
Next i
End If

Next n
TempWks.Delete

Application.DisplayAlerts = True
MsgBox "Report generated"


End Sub


since it deletes randomly any row so necessarily not 1st row always..

Cheers!!
excelliot.com

[shan]

Thank you Sir.. I have tried this ...
I am using this same code in another file ... I had made changes in columns ... but when I am running this macro each time the number of rows get copied on "C", "R" and "T" sheets are different for same percentage defined. Ideally the number of rows should be same only the data featuring under these rows will be different.

I think I had missed on some changes ... Changes I had made are highlighted in Bold


Sub sampling()
Dim myCell As Range
Dim wks As Worksheet
Dim DataBaseWks As Worksheet
Dim ListRange As Range
Dim dummyRng As Range
Dim myDatabase As Range
Dim TempWks As Worksheet
Dim rsp As Integer
Dim i As Long
Dim fCriterion As String, fPc As Integer
Dim lr As Integer, lr2 As Integer

Const TopLeftCellOfDataBase As String = "A1"
Const KeyColumn As String = "F" ................... changed from column "B" to "F"


Set DataBaseWks = Worksheets("sheet2") ................... changed sheet name from "raw data" to "sheet2"
i = DataBaseWks.Range(TopLeftCellOfDataBase).Row - 1

'fCriterion = Application.InputBox("Enter Trype value for filtering data")
'fPc = Application.InputBox("Enter % in numbers")


Application.DisplayAlerts = False
Set TempWks = Worksheets.Add


With DataBaseWks
Set dummyRng = .UsedRange
Set myDatabase = .Range(TopLeftCellOfDataBase, _
.Cells.SpecialCells(xlCellTypeLastCell))
End With


With DataBaseWks
Intersect(myDatabase, .Columns(KeyColumn)).AdvancedFilter _
Action:=xlFilterCopy, _
CopyToRange:=TempWks.Range("A1"), _
Unique:=True


TempWks.Range("BH1").Value = _ ................... changed from column "D1" to "BH1" ... the blank column
.Cells(.Range(TopLeftCellOfDataBase).Row, KeyColumn).Value
End With


With TempWks
Set ListRange = .Range("A2", .Cells(.Rows.Count, "A").End(xlUp))
End With


With ListRange
.Sort Key1:=.Cells(1), Order1:=xlAscending, _
Header:=xlNo, OrderCustom:=1, _
MatchCase:=False, Orientation:=xlTopToBottom
End With


'For Each myCell In ListRange.Cells
For n = 1 To 3
If n = 1 Then
fCriterion = "C": fPc = 20 '<======================
ElseIf n = 2 Then
fCriterion = "R": fPc = 95
Else
fCriterion = "T": fPc = 1
End If

If WksExists(fCriterion) = False Then
Set wks = Sheets.Add
On Error Resume Next
wks.Name = fCriterion 'myCell.Value
If Err.Number <> 0 Then
MsgBox "Please rename: " & wks.Name
Err.Clear

End If
On Error GoTo 0
wks.Move After:=Sheets(Sheets.Count)
Else
Set wks = Worksheets(fCriterion)
wks.Cells.Clear
End If

If rsp = 6 Then
DataBaseWks.Rows("1:" & i).Copy Destination:=wks.Range("A1")
End If

TempWks.Range("BH2").Value = "=" & Chr(34) & "=" & fCriterion & Chr(34) ................... changed from column "D2" to "BH2"

If rsp = 6 Then
myDatabase.AdvancedFilter _
Action:=xlFilterCopy, _
CriteriaRange:=TempWks.Range("BH1:BH2"), _ ................... changed from column "D1:D2" to "BH1:BH2"
CopyToRange:=wks.Range("A1").Offset(i, 0), _
Unique:=True
Else
myDatabase.AdvancedFilter _
Action:=xlFilterCopy, _
CriteriaRange:=TempWks.Range("BH1:BH2"), _ ................... changed from column "D1:D2" to "BH1:BH2"
CopyToRange:=wks.Range("A1"), _
Unique:=True
'Columns("BH:BH").ColumnWidth = 25 ................... changed from column "D:D" to "BH:BH" ... It is not require but still changed
End If


wks.Activate

'remove duplicate
lr3 = Cells(Rows.Count, 1).End(xlUp).Row
For i = lr3 To 2 Step -1
If Application.WorksheetFunction.CountIf(Range("E2:E" & lr3), Cells(i, 5)) > 1 Then ................... changed from column "C1:C" to "E1:E"
Cells(i, 5).EntireRow.Delete ................... changed from "3" to "5"
End If
Next i

lr = Cells(Rows.Count, 1).End(xlUp).Row
'lr2 = Application.WorksheetFunction.Max(1, Round((lr - 1) * fPc / 100, 0)) + 2
lr2 = Application.WorksheetFunction.RoundUp((lr - 1) * fPc / 100, 0) + 0

'Range("A" & lr2 & ":A" & lr).EntireRow.Delete
If lr2 < lr Then
For i = 1 To (lr - lr2)
Range("A" & Int((lr - 1) * Rnd + 2)).EntireRow.Delete
Next i
End If

Next n
TempWks.Delete

Application.DisplayAlerts = True
MsgBox "Report generated"


End Sub
Function WksExists(wksName As String) As Boolean
On Error Resume Next
WksExists = CBool(Len(Worksheets(wksName).Name) > 0)
End Function

[shan]

Sir .. Now I have tried the code on the same original file but here also the row count is changing when I run the code for same percentage.

[excelliot]

try this:



Sub sampling()
Dim myCell As Range
Dim wks As Worksheet
Dim DataBaseWks As Worksheet
Dim ListRange As Range
Dim dummyRng As Range
Dim myDatabase As Range
Dim TempWks As Worksheet
Dim rsp As Integer
Dim i As Long
Dim fCriterion As String, fPc As Integer
Dim lr As Integer, lr2 As Integer

Const TopLeftCellOfDataBase As String = "A1"
Const KeyColumn As String = "B"

Set DataBaseWks = Worksheets("raw data")
i = DataBaseWks.Range(TopLeftCellOfDataBase).Row - 1

'fCriterion = Application.InputBox("Enter Trype value for filtering data")
'fPc = Application.InputBox("Enter % in numbers")

Application.DisplayAlerts = False
Set TempWks = Worksheets.Add

With DataBaseWks
Set dummyRng = .UsedRange
Set myDatabase = .Range(TopLeftCellOfDataBase, _
.Cells.SpecialCells(xlCellTypeLastCell))
End With

With DataBaseWks
Intersect(myDatabase, .Columns(KeyColumn)).AdvancedFilter _
Action:=xlFilterCopy, _
CopyToRange:=TempWks.Range("A1"), _
Unique:=True

TempWks.Range("D1").Value = _
.Cells(.Range(TopLeftCellOfDataBase).Row, KeyColumn).Value
End With

With TempWks
Set ListRange = .Range("A2", .Cells(.Rows.Count, "A").End(xlUp))
End With

With ListRange
.Sort Key1:=.Cells(1), Order1:=xlAscending, _
Header:=xlNo, OrderCustom:=1, _
MatchCase:=False, Orientation:=xlTopToBottom
End With

'For Each myCell In ListRange.Cells
For n = 1 To 3
If n = 1 Then
fCriterion = "C": fPc = 90 '<======================
ElseIf n = 2 Then
fCriterion = "R": fPc = 55
Else
fCriterion = "T": fPc = 80
End If

If WksExists(fCriterion) = False Then
Set wks = Sheets.Add
On Error Resume Next
wks.Name = fCriterion 'myCell.Value
If Err.Number <> 0 Then
MsgBox "Please rename: " & wks.Name
Err.Clear

End If
On Error GoTo 0
wks.Move After:=Sheets(Sheets.Count)
Else
Set wks = Worksheets(fCriterion)
wks.Cells.Clear
End If

If rsp = 6 Then
DataBaseWks.Rows("1:" & i).Copy Destination:=wks.Range("A1")
End If

TempWks.Range("D2").Value = "=" & Chr(34) & "=" & fCriterion & Chr(34)

If rsp = 6 Then
myDatabase.AdvancedFilter _
Action:=xlFilterCopy, _
CriteriaRange:=TempWks.Range("D1:D2"), _
CopyToRange:=wks.Range("A1").Offset(i, 0), _
Unique:=True
Else
myDatabase.AdvancedFilter _
Action:=xlFilterCopy, _
CriteriaRange:=TempWks.Range("D1:D2"), _
CopyToRange:=wks.Range("A1"), _
Unique:=True
'Columns("D:D").ColumnWidth = 25
End If


wks.Activate

'remove duplicate
lr3 = Cells(Rows.Count, 1).End(xlUp).Row
For i = lr3 To 2 Step -1
If Application.WorksheetFunction.CountIf(Range("C2:C" & lr3), Cells(i, 3)) > 1 Then
Cells(i, 3).EntireRow.Delete
End If
Next i

lr = Cells(Rows.Count, 1).End(xlUp).Row
'lr2 = Application.WorksheetFunction.Max(1, Round((lr - 1) * fPc / 100, 0)) + 2
lr2 = Application.WorksheetFunction.RoundUp((lr - 1) * fPc / 100, 0) + 1

'Range("A" & lr2 & ":A" & lr).EntireRow.Delete
If lr2 < lr Then
For i = 1 To (lr - lr2)
'Range("A" & Int((lr - 1) * Rnd + 2)).EntireRow.Delete
Range("A" & Application.WorksheetFunction.RandBetween(2, lr)).EntireRow.Delete
Next i
End If

Next n
TempWks.Delete

Application.DisplayAlerts = True
MsgBox "Report generated"

End Sub
Function WksExists(wksName As String) As Boolean
On Error Resume Next
WksExists = CBool(Len(Worksheets(wksName).Name) > 0)
End Function


Please note code takes column A as base for counting number of rows, if it is not so then it needs to be changed..

[shan]

Sir...I have tried this code .. still the same problem...

Every time I run this code its giving me a different no of row count for same percentage!!!

There should be data available in column A for row counting ... data is available in Column A

[excelliot]

Column A, B & c is having same number of rows?

[shan]

yes

[excelliot]

check this...

I tried on this data & i am getting correct result every time..

[shan]

Good Morning Sir!!!
Yes you are right. But when I am changing percentage as C=1, R=2 and T=1 then no of rows changing every time.

or n = 1 To 3
If n = 1 Then
fCriterion = "C": fPc = 1 '<======================
ElseIf n = 2 Then
fCriterion = "R": fPc = 2
Else
fCriterion = "T": fPc = 1
End If

[shan]

Sir .. for any other percentage the row count is changing on each run..
Now I have tried C=8, R=10, T=15 ... ideally I should get 1 row for C, R and T ... but at first run I got 3 row for C, 2 rows for R and 1 row for T.
When I again ran the code it gave me 2 rows for C, 3 rows R and 2 rows for T

[excelliot]

ok, i got error, pl check revised code:



Sub sampling()
Dim myCell As Range
Dim wks As Worksheet
Dim DataBaseWks As Worksheet
Dim ListRange As Range
Dim dummyRng As Range
Dim myDatabase As Range
Dim TempWks As Worksheet
Dim rsp As Integer
Dim i As Long, ii As Integer
Dim fCriterion As String, fPc As Integer
Dim lr As Integer, lr2 As Integer

Const TopLeftCellOfDataBase As String = "A1"
Const KeyColumn As String = "B"

Set DataBaseWks = Worksheets("raw data")
i = DataBaseWks.Range(TopLeftCellOfDataBase).Row - 1
n = 0
'fCriterion = Application.InputBox("Enter Trype value for filtering data")
'fPc = Application.InputBox("Enter % in numbers")

Application.DisplayAlerts = False
Set TempWks = Worksheets.Add

With DataBaseWks
Set dummyRng = .UsedRange
Set myDatabase = .Range(TopLeftCellOfDataBase, _
.Cells.SpecialCells(xlCellTypeLastCell))
End With

With DataBaseWks
Intersect(myDatabase, .Columns(KeyColumn)).AdvancedFilter _
Action:=xlFilterCopy, _
CopyToRange:=TempWks.Range("A1"), _
Unique:=True

TempWks.Range("D1").Value = _
.Cells(.Range(TopLeftCellOfDataBase).Row, KeyColumn).Value
End With

With TempWks
Set ListRange = .Range("A2", .Cells(.Rows.Count, "A").End(xlUp))
End With

With ListRange
.Sort Key1:=.Cells(1), Order1:=xlAscending, _
Header:=xlNo, OrderCustom:=1, _
MatchCase:=False, Orientation:=xlTopToBottom
End With

'For Each myCell In ListRange.Cells
For n = 1 To 3
If n = 1 Then
fCriterion = "C": fPc = 90 '<======================
ElseIf n = 2 Then
fCriterion = "R": fPc = 55
Else
fCriterion = "T": fPc = 80
End If

If WksExists(fCriterion) = False Then
Set wks = Sheets.Add
On Error Resume Next
wks.Name = fCriterion 'myCell.Value
If Err.Number <> 0 Then
MsgBox "Please rename: " & wks.Name
Err.Clear

End If
On Error GoTo 0
wks.Move After:=Sheets(Sheets.Count)
Else
Set wks = Worksheets(fCriterion)
wks.Cells.Clear
End If

If rsp = 6 Then
DataBaseWks.Rows("1:" & i).Copy Destination:=wks.Range("A1")
End If

TempWks.Range("D2").Value = "=" & Chr(34) & "=" & fCriterion & Chr(34)

If rsp = 6 Then
myDatabase.AdvancedFilter _
Action:=xlFilterCopy, _
CriteriaRange:=TempWks.Range("D1:D2"), _
CopyToRange:=wks.Range("A1").Offset(i, 0), _
Unique:=True
Else
myDatabase.AdvancedFilter _
Action:=xlFilterCopy, _
CriteriaRange:=TempWks.Range("D1:D2"), _
CopyToRange:=wks.Range("A1"), _
Unique:=True
'Columns("D:D").ColumnWidth = 25
End If


wks.Activate

'remove duplicate
lr3 = Cells(Rows.Count, 1).End(xlUp).Row
For ii = lr3 To 2 Step -1
If Application.WorksheetFunction.CountIf(Range("C2:C" & lr3), Cells(ii, 3)) > 1 Then
Cells(i, 3).EntireRow.Delete
End If
Next ii

lr = Cells(Rows.Count, 1).End(xlUp).Row
'lr2 = Application.WorksheetFunction.Max(1, Round((lr - 1) * fPc / 100, 0)) + 2
lr2 = Application.WorksheetFunction.RoundUp((lr - 1) * fPc / 100, 0) + 1

'Range("A" & lr2 & ":A" & lr).EntireRow.Delete
If lr2 < lr Then
For i = 1 To (lr - lr2)
'Range("A" & Int((lr - 1) * Rnd + 2)).EntireRow.Delete
lr = Cells(Rows.Count, 1).End(xlUp).Row
Range("A" & Application.WorksheetFunction.RandBetween(2, lr)).EntireRow.Delete
Next i
End If

Next n
TempWks.Delete

Application.DisplayAlerts = True
MsgBox "Report generated"

End Sub
Function WksExists(wksName As String) As Boolean
On Error Resume Next
WksExists = CBool(Len(Worksheets(wksName).Name) > 0)
End Function


Cheers!!
excelliot.com

[shan]

Great Sir !!

Its working absolutely fine !!

Thank you so much!!!

[excelliot]

Cheers Buddy!

www.excelliot.com

[shan]

How do I mention .. This query is resolved?

[excelliot]

Check in thread tools on the top..