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

**shan** · 06-19-2015, 05:19 AM

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

**excelliot** · 06-19-2015, 07:05 AM

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** · 06-21-2015, 10:05 PM

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

**shan** · 06-22-2015, 12:08 AM

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** · 06-22-2015, 03:37 AM

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** · 06-22-2015, 04:12 AM

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** · 06-22-2015, 04:47 AM

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

**shan** · 06-22-2015, 04:54 AM

yes

**excelliot** · 06-22-2015, 07:35 AM

check this...

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

**shan** · 06-22-2015, 08:51 PM

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** · 06-22-2015, 09:03 PM

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** · 06-23-2015, 01:24 AM

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** · 06-23-2015, 02:53 AM

Great Sir !!

Its working absolutely fine !!

Thank you so much!!!

**excelliot** · 06-23-2015, 03:29 AM

Cheers Buddy!

www.excelliot.com

**shan** · 06-24-2015, 11:11 PM

How do I mention .. This query is resolved?

**excelliot** · 06-24-2015, 11:30 PM

Check in thread tools on the top..

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

Thread Tools

Display

Tags for this Thread

Posting Permissions