mardi 25 février 2020

VBA - Sample (random) based on a cell - Selection of 5 items and take all rows for this item (+do not take item which have over 20 rows)

My first question here after many years as observer.

I am facing a problem in VBA. I am kind of noob - self-learner and this is a bit over my capabilities.

I have an Excel workbook with almost 100k rows. Here are some example of content (labels changed, only useful col):

Col A: LOT (Can be ABC or DEF)
Col B: Name
Col C: Value
Col D: Data

What I wish to do is for only DEF (Col A) and Value X99 (Col C), have a sample of 5 Names (Col B) with all rows of these names. Col B, you have a name which can have many Data - so for the same name you can have X rows.

I also want an exeption, it is that for each names having over 20 lines, I do not want to have them in my selection.

The goal is then to take the values and paste them in another workbook.

Here is a code I have been using for another random selection in this workbook. (Sorry the code is not nice att all as I am beginner)

Dim SQLr, ABC, DEF, RNDsh As Worksheet
Dim lastrow As Long
Dim i As Long
Dim d, n As Date
Dim searchfor As String
Dim Rng As Range

Dim MyRows() As Integer
Dim numRows, rndRows, nxtRow, nxtRnd, chkRnd, copyRow As Integer

'°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°° Checking 11, DEF
DEF.Activate
Range("A130").FormulaR1C1 = "11. SEPA DIRECT DEBIT"
Range("A130").Select
With Selection.Font
    .Name = "Arial"
End With
Selection.Font.Bold = True

    SQLr.Select
    SQLr.ListObjects("SQL_table").Range.AutoFilter Field:=1, Criteria1:="DEF"
    SQLr.ListObjects("SQL_table").Range.AutoFilter Field:=12, Criteria1:="=*X90*", Operator:=xlAnd

    On Error Resume Next
Set Rng = Range("SQL_table").SpecialCells(xlCellTypeVisible)
    On Error GoTo 0
'Copy filtered data to "RNDsh"
If Not Rng Is Nothing Then
Rng.Copy
RNDsh.Select
Range("A1").Select
ActiveSheet.Paste
ActiveCell.Columns("A:A").EntireColumn.EntireColumn.AutoFit
Randomize 'Initialize Random number seed and process the selection (sampling)
    numRows = Sheets("RNDsh").Range("A" & Rows.Count).End(xlUp).Row
    If numRows > 5 Then
        rndRows = 5  'Get a selection of 5 rows (sample)
        ReDim MyRows(rndRows)
            For nxtRow = 1 To rndRows

 getNew:
  nxtRnd = Int((numRows) * Rnd + 1)

                `chkRnd = 1 To nxtRow                   'Loop through array, checking for  Duplicates
            If MyRows(chkRnd) = nxtRnd Then GoTo getNew    'Get new number if Duplicate is found
                Next
        MyRows(nxtRow) = nxtRnd                           'Add element if Random number is unique
            Next
'Loop through Array, copying rows to DEF
    For copyRow = 1 To rndRows
     RNDsh.Rows(MyRows(copyRow)).EntireRow.Copy Destination:=Sheets("LPB").Cells(130 + copyRow, 1)
     DEF.Cells(130 + copyRow, 1).AddComment
     DEF.Cells(130 + copyRow, 1).Comment.Visible = False
     DEF.Cells(130 + copyRow, 1).Comment.Text Text:="Automatic Random - Macro."
    Next

    ElseIf numRows < 5 Then
        Application.CutCopyMode = False
        Selection.Cut
        Sheets("DEF").Select
        Rows("131:131").Select
        Selection.Insert Shift:=xlDown
    End If

'Clean RNDsh sheet
RNDsh.Select
Cells.Select
Selection.Delete Shift:=xlUp
ElseIf Rng Is Nothing Then LPB.Range("F130").FormulaR1C1 = "NO SEPA DIRECT DEBIT: PLEASE CHECK"
End If`

Actually, for the random selection I have been previously doing, I created a sheet "RNDsh" where I pasted the filtered data (with 2 criterias) from the first sheet.

Thank you for your help :-)




Aucun commentaire:

Enregistrer un commentaire