Creare test copiando riga random

Question

Ciao a tutti e buon 2018,

vorrei:

1. compilare il foglio di lavoro test copiando il range A:E
2. avere la possibilità di scegliere se il test debba essere composto da domande prelevate da un foglio singolo o se frutto di un mix dei vari fogli presenti.

In entrambi i casi deve essere rispettato il numero massimo previsto in K1 del foglio TEST

Io sono arrivato a copiare solamente una cella per un foglio di lavoro specifico:

>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>

Public Sub EstraiCelleDaElenco()

  Dim arr As New Collection

  Dim i As Long

  Dim IndiceCasuale As String

  Dim DA_ESTRARRE As Integer

  Dim Estratti As Integer

  DA_ESTRARRE = Sheet2.Range("k1")

  'Pulisco colonna dove estrarre i numeri

  Sheet2.Select

  Last_Row2 = Sheet2.Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row

  If Last_Row2 > 1 Then

     Sheet2.Range(Cells(2, 1), Cells(Last_Row2, 1)).ClearContents

  End If

  'Individuo ultima riga non vuota dell'elenco

  MAX = Sheet1.Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row

  'Definisco intervallo inferiore (indice della prima riga contente i dati)

  MIN = 2  'é la riga del primo elemento dell'elenco

  'Ripeto il ciclo DO-LOOP fino a quando il numero di elementi contenuti nel vettore 'arr'

  'è uguale al numero degli elementi da estrarre 'DA_ESTRARRE

  Do Until arr.Count = DA_ESTRARRE

  'estraggo un numero da inserire in un vettore

  IndiceCasuale = Int((MAX - MIN + 1) * Rnd + MIN)

  'Se il numero fosse già presente nel vettore, non sarebbe possibile inserirlo e si genererebbe un errore.

  'Ottengo quindi il risultato voluto (estrazione senza ripetizione)

  'e faccio riprendere il ciclo

  On Error Resume Next

  arr.Add IndiceCasuale, IndiceCasuale

  Loop

  For i = 1 To arr.Count

  'Ricalcolo l'ultima riga vuota del foglio in cui estrarre i dati

  Last_Row2 = Sheet2.Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row

  'Copio nel foglio ESTRAZIONE i valori del foglio DATI

  'utilizzando i numeri di riga casuali estratti precedentemente ed inseriti nel vettore arr

  'di cui prendo gli gli elementi 'i' dal numero 1 all'ultimo arr.Count

  Sheet2.Cells(Last_Row2 + 1, 1) = Sheet1.Cells(arr(i), 1)

  Next

End Sub

<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<

https://www.dropbox.com/s/je5dyl2hnq70hjh/Crea%20TestV1.xlsm?dl=0

Grazie per l'aiuto.

Answer 1

Ciao By EF,

Ciao GianMarco Zen,

grazie per la risposta che, però, mi fà sorgere il dubbio di non aver spiegato bene l'aiuto che necessito. Quindi, provo a semplificare il tutto:

la richiesta di aiuto, verte su come modificare la macro VBA per copiare un range dove attualmente copio una riga. Quindi, confido nell'immensa preparazione e disponibilità di Norman David Jones (che saluto) per arrivare a [RISOLTO].

Prova a sostituire il tuo codice con la seguente versione:

'=========>>

Option Explicit

'--------->>

Public Sub EstraiCelleDaElenco()

    Dim WB As Workbook

    Dim SH As Worksheet, SH_Test As Worksheet

    Dim Rng As Range, destRng As Range

    Dim oDic As Object

    Dim arrSplit As Variant, arrTemp As Variant, arrTemp2() As Variant

    Dim arrDomande() As Variant, arrOut() As Variant

    Dim myCollection As Collection

    Dim i As Long, j As Long, k As Long

    Dim ii As Long, jj As Long, kk As Long

    Dim iCtr As Long, UB2 As Long

    Dim LRow As Long

    Dim DA_ESTRARRE As Long

    Const sFogliDomande As String = "STORIA,ITALIANO,Matematica"

    Const sFoglioTest As String = "TEST"

    Set WB = ThisWorkbook

    With WB

        Set SH_Test = .Sheets(sFoglioTest)

        arrSplit = Split(sFogliDomande, ",")

        If UBound(arrSplit) = 0 Then

            Set SH = .Sheets(sFogliDomande)

            With SH

                LRow = LastRow(SH, .Columns("A:A"))

                Set Rng = .Range("A2:E" & LRow)

            End With

            arrDomande = Rng.Value

        Else

            For i = LBound(arrSplit) To UBound(arrSplit)

                Set SH = .Sheets(arrSplit(i))

                With SH

                    LRow = LastRow(SH, .Columns("A:A"))

                    Set Rng = .Range("A2:E" & LRow)

                    If i = 0 Then

                        arrDomande = Application.Transpose(Rng.Value)

                        iCtr = UBound(arrDomande, 2)

                        UB2 = UBound(arrDomande)

                    Else

                        LRow = LastRow(SH, .Columns("A:A"))

                        Set Rng = .Range("A2:E" & LRow)

                        arrTemp = Rng.Value

                        ReDim Preserve arrDomande(1 To UB2, 1 To iCtr + UBound(arrTemp))

                        For j = 1 To UBound(arrTemp)

                            iCtr = iCtr + 1

                            For k = 1 To UB2

                                arrDomande(k, iCtr) = arrTemp(j, k)

                            Next k

                        Next j

                    End If

                End With

            Next i

        End If

    End With

    iMax = UBound(arrDomande, 2)

    With SH_Test

        DA_ESTRARRE = .Range("K1").Value

        .UsedRange.Offset(1).ClearContents

        Set destRng = .Range("A2")

    End With

    ReDim arrTemp(1 To iCtr)

    For j = 1 To iCtr

        arrTemp(j) = j

    Next j

       arrTemp2 = ShuffleArray(arrTemp)

        ReDim arrOut(1 To DA_ESTRARRE, 1 To UB2)

        For jj = 1 To DA_ESTRARRE

            For kk = 1 To UB2

                arrOut(jj, kk) = arrDomande(kk, arrTemp2(jj))

            Next kk

        Next jj

    On Error GoTo XIT

    Application.ScreenUpdating = False

    destRng.Resize(DA_ESTRARRE, UB2).Value = arrOut

    Call MsgBox( _

         Prompt:="Il Test ò pronto e comprende " _

                 & UBound(arrOut) & " domande!", _

         Buttons:=vbInformation, _

         Title:="REPORT")

XIT:

    Application.ScreenUpdating = True

    Set myCollection = Nothing

End Sub

'--------->>

Public Function ShuffleArray(InArray)

    Dim Arr() As Variant

    Dim vTemp As Variant

    Dim i As Long, j As Long, k As Long

    Randomize

    i = UBound(InArray) - LBound(InArray) + 1

    ReDim Arr(LBound(InArray) To UBound(InArray))

    For j = LBound(InArray) To UBound(InArray)

        Arr(j) = InArray(j)

    Next j

    For j = LBound(InArray) To UBound(InArray)

        k = CLng(((UBound(InArray) - j) * Rnd) + j)

        vTemp = Arr(j)

        Arr(j) = Arr(k)

        Arr(k) = vTemp

    Next j

    ShuffleArray = Arr

End Function

'--------->>

Public Function LastRow(SH As Worksheet, _

                        Optional Rng As Range, _

                        Optional minRow As Long = 1, _

                        Optional sPassword As String)

    Dim bProtected As Boolean

    With SH

        If Rng Is Nothing Then

            Set Rng = .Cells

        End If

        bProtected = .ProtectContents = True

        If bProtected Then

            Application.ScreenUpdating = False

            .Unprotect Password:=sPassword

        End If

    End With

    On Error Resume Next

    LastRow = Rng.Find(What:="*", _

                       after:=Rng.Cells(1), _

                       Lookat:=xlPart, _

                       LookIn:=xlFormulas, _

                       SearchOrder:=xlByRows, _

                       SearchDirection:=xlPrevious, _

                       MatchCase:=False).Row

    On Error GoTo 0

    If LastRow < minRow Then

        LastRow = minRow

    End If

    If bProtected Then

        SH.Protect Password:=sPassword, _

                   UserInterfaceOnly:=True

    End If

    Application.ScreenUpdating = True

End Function

'<<=========

Potresti scaricare il mio file di prova ByEF20180122.xlsm

===

Regards,

Norman

Answer 2

Ciao By EF,

Ciao Norman,

è perfetto.

Bene, sono lieto!

Mi fa piacere anche che non sia stato necessario pergrinare altrove per trovare una soluzione. 

===

Regards,

Norman

Answer 3

Ciao Norman,

è perfetto.

Grazie ancora e alla prossima

byEF

Answer 4

Ciao GianMarco Zen,

grazie per la risposta che, però, mi fà sorgere il dubbio di non aver spiegato bene l'aiuto che necessito. Quindi, provo a semplificare il tutto:

la richiesta di aiuto, verte su come modificare la macro VBA per copiare un range dove attualmente copio una riga. Quindi, confido nell'immensa preparazione e disponibilità di Norman David Jones (che saluto) per arrivare a [RISOLTO].

by EF

Answer 5

Ciao By Ef!

Domande come la tua sono più indicate per il nostro forum gemello MSDN, frequentato da esperti programmatori che sapranno sicuramente darti una mano in questo senso.

Tuttavia, lascio il thread aperto per permettere ai membri di questa community, anche loro molto attivi in fatto di Office ed Excel, di postare una possibile soluzione al tuo problema, che spero tu riesca a trovare quanto prima!

Un saluto,

Gianmarco