Sir... can you please help me with these changes... instead of first rows i want to pickup any row...
Sir... can you please help me with these changes... instead of first rows i want to pickup any row...
Ok, try this code:
since it deletes randomly any row so necessarily not 1st row always..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
Cheers!!
excelliot.com
A mighty flame followeth a tiny sparkle!!
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 "D12" 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 "D12" to "BH1:BH2"
CopyToRange:=wks.Range("A1"), _
Unique:=True
'Columns("BH:BH").ColumnWidth = 25 ................... changed from column "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
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.
try this:
Please note code takes column A as base for counting number of rows, if it is not so then it needs to be changed..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
A mighty flame followeth a tiny sparkle!!
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
Column A, B & c is having same number of rows?
A mighty flame followeth a tiny sparkle!!
yes
check this...
I tried on this data & i am getting correct result every time..
A mighty flame followeth a tiny sparkle!!
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
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
ok, i got error, pl check revised code:
Cheers!!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
excelliot.com
Last edited by excelliot; 06-23-2015 at 01:42 AM.
A mighty flame followeth a tiny sparkle!!
Great Sir !!
Its working absolutely fine !!
Thank you so much!!!
Cheers Buddy!
www.excelliot.com
A mighty flame followeth a tiny sparkle!!
How do I mention .. This query is resolved?
Check in thread tools on the top..
A mighty flame followeth a tiny sparkle!!