Macro extractie aleatorie

[corcodel]

Salut,
Va rog sa ma ajutati cu un macro care sa extraga dintr-un fisier excel, in mod aleatoriu, 10 referinte dintr-o singura luna, chiar daca fisierul contine date si din alte luni. Daca este posibil sa extraga doar valori unice, nu dubluri. Atasat fisier.
Multumesc!

Sinteza:
DE ADUS COLOANLE IN MOD ALEATORIU 10 REFERINTE DIN LUNA A 10
A - N°REFERENCE
B- DESTIGNATION
G-DATE DE TRAITEE
H- TRAITEE PAR
fara dubluri

[IPP]

Buna ziua

Atasat aveti spre testare o propune.
Obiectiv: extragerea primelor 10 informatii (aferente a 4 coloane) in functie de luna precizata de utilizator si fara duplicate vizavi de informatia de pe coloana A.

Observatii: data calendaristica asa cum apare in fisierul exemplu nu este data calendaristica (in sensul inteles de Excel) ci informatie de tip text, de aici si codul diferit atunci cand e vorba de identificat luna de interes
Daca modul in care e acum sortata lista sursa nu e satisfacator (de exemplu sunt sanse mari ca informatia "aleatorie" sa faca parte intodeauna din primele zile ale lunii de interes) sugestia mea ar fi sa mai faceti o operatiune prealabila suplimentara: pe o coloana alaturata introduceti o functie de tip RAND / RANDBETWEEN, salvati rezultatele ca valori si faceti o sortare bazata pe valorile din aceasta coloana. Dupa aceea rulati macro de extragere info.

Premise: nu se vor redenumi foile implicate sau se va edita in cod
In acest moment codul e gandit pentru 65536 de randuri in foaia sursa. Daca situatia o impune se va modifica cu o valoare <1048000

Am folosit urmatorul cod:

Cod: Selectaţi tot

Sub ExtrageInfo()

'IPP - 22.11.2018

Dim rngSursa As Range
 Set rngSursa = Sheets("Sheet1").Range("A2:A" & Sheets("Sheet1").Range("A65536").End(xlUp).Row)

Dim cLuna As Range
 Set cLuna = Sheets("Results").Range("A2")

Dim rngResults As Range

Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual

Sheets("Results").Range("A5").CurrentRegion.Offset(1, 0).ClearContents

For Each c In rngSursa
 Set rngResults = Sheets("Results").Range("A5").CurrentRegion.Columns(1).Cells
 
If rngResults.Cells.Count = 11 Then GoTo endSub
 
 If cLuna.Value = Mid(c.Offset(0, 6), 4, 2) + 0 Then
  If Application.WorksheetFunction.CountIf(rngResults, c) = 0 Then
   With Sheets("Results").Range("A65536").End(xlUp).Offset(1, 0)
   .Value = c.Value
   .Offset(0, 1) = c.Offset(0, 1)
   .Offset(0, 2) = c.Offset(0, 6)
   .Offset(0, 3) = c.Offset(0, 7)
   End With
  End If
End If

Next c

endSub:
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True

End Sub

Acesta: sterge eventuala informatie veche in foaia de destinatie (Results); parcurge fiecare cod din foaia sursa si, daca lista finala nu are deja 10 item-uri cu informatia aferenta scrie, evitand duplicatele, informatia de pe coloanele A, B, G, H din foaia sursa in foaia destinatie.

Pentru testare: deschideti fisierul atasat, activati macro/continutul, specificati nr lunii in foaia Results, celula A2 si rulati macro.

IP

PS. Am mutat subiectul la sectiunea dedicata, nu v-am aprobat al doilea mesaj pe motiv de mesaj dublat. Cf. regulamentului acestui forum trebuie sa asteptati aprobarea primelor doua mesaje inainte de orice. De asemenea, pe viitor, va rugam sa deschideti subiectele la sectiunile corespunzatoare versiunii de Excel folosite sau VBA daca e cazul.

[corcodel]

Salut,
Eu folosesc un macro care face extractia aleatorie a 30 de referinte, insa nu tine cont de luna. Adica, daca am mai multe date din mai multe luni ale anului, iar mie imi trebuie date din luna ce a trecut, acest macro imi aduce si cateva date din lunile precedente. Nu stiu ce as mai putea adauga astfel incat selectia aleatorie sa se faca doar pe ntru o anumita luna. Mai jos, macro:

Sub Random30()
Dim wbs As Workbook 'workbook sursa date
Dim wbd As Workbook ' workbook destinatie date
Dim wss As Worksheet 'worksheet sursa date
Dim wsd As Worksheet 'worksheet destinatie date



Set wbd = ThisWorkbook
Set wsd = wbd.Worksheets("Random")


Set wbs = Workbooks.Open(ThisWorkbook.Path & "\" & wsd.Range("A1").Value)
'cauta in prima foaie
Set wss = wbs.Worksheets(1)
Lastrow = wss.Cells(wss.Rows.Count, "A").End(xlUp).Row
'Initialize the random number generator
'=> Randomize : add this before you call the Rnd function to obtain completely random values

'Daca vrei sa schimbi nr de randuri inlocuiesti 30 cu cat vrei
For i = 2 To 38

Randomize

random_number = Int(Lastrow * Rnd) + 2
wss.Range("A" & random_number).Copy _
Destination:=wsd.Range("B" & i)
wss.Range("C" & random_number).Copy _
Destination:=wsd.Range("C" & i)
wss.Range("J" & random_number).Copy _
Destination:=wsd.Range("E" & i)
wss.Range("R" & random_number).Copy _
Destination:=wsd.Range("D" & i)

Next i
wbs.Close savechanges:=False
End Sub

[corcodel]

Atasez si fisier nou.