Plusieurs macros en une
Bonjour le forum
J'ai regroupé plusieurs macros pour effectuer le calcul d'une plage de données (plage test)
Tout s'effectue bien jusqu'a la recopie dans la feuil"grille3" qui ne se fait pas.
je voudrais mettre un critere pour ne prendre que les données en colonne O superieur a une certaine valeur pour le
moment superieur a 70. Mais là je ne sais comment faire.
Si quelqu'un peut m'aider merci d'avance
joint fichier
merci
Sub Macro1()
'
' Macro1 Macro
' macro automatique
'
' efface plage B3:V...
Dim aa As Worksheet
Range("B3:V1142").ClearContents
'Set aa = Worksheets("Combi")
'aa.Range(aa.Cells(3, 1), aa.Cells(Rows.Count, 22)).ClearContents
'copie ligne w3:ap3 et colle en B1:U1
Range("W3:AP3").Select
Selection.Copy
Range("B1").Select
ActiveSheet.Paste
'effectue le calcul
'Sub Main()
Dim Ta&(), Tc&(), Tb&(), w As Worksheet, NbA&, NbB&, NbC#, i&, j&, k&, h&, Lg&, Co&, M As Byte, R As Byte
Set w = Worksheets("Combi")
w.Range(w.Cells(3, 1), w.Cells(Rows.Count, 22)).ClearContents
NbA = w.Cells(1, Columns.Count).End(xlToLeft).Column - 1
On Error Resume Next
NbB = w.Cells(2, 2)
On Error GoTo 0
If NbB = 0 Then MsgBox "Inscrire le nombre de n° par combinaisons en B2": Exit Sub
If NbB > 10 Then MsgBox "Nombre de n° par combinaisons en B2 <= 10": Exit Sub
If NbB > NbA Then MsgBox "Pas assez de n° trouvés en ligne A": Exit Sub
On Error Resume Next
NbC = CmbNb(NbA, NbB)
On Error GoTo 0
If NbC = 0 Or NbC > Rows.Count Then MsgBox "Trops de combinaisons": Exit Sub
ReDim Ta(1 To NbA)
For i = 1 To NbA
On Error Resume Next
Ta(i) = w.Cells(1, i + 1)
On Error GoTo 0
If Ta(i) = 0 Then MsgBox "Anomalie en cellule ligne 1, colonne " & (i + 1): Exit Sub
For j = 1 To i - 1
If Not Ta(i) > Ta(j) Then MsgBox "Anomalie : doublon ou mauvais rangement en ligne 1": Exit Sub
Next j, i
Tc = CmbTab(NbA, NbB)
For i = 1 To NbC
For j = 1 To NbB
Tc(i, j) = Ta(Tc(i, j))
Next j
Next i
Erase Ta
w.Range(w.Cells(3, 2), w.Cells(2 + NbC, 1 + NbB)) = Tc
Lg = w.Cells(Rows.Count, 23).End(xlUp).Row - 2
Co = w.Cells(3, Columns.Count).End(xlToLeft).Column - 22
ReDim Ta(1 To Lg, 1 To Co)
For i = 1 To Lg
For j = 1 To Co
Ta(i, j) = w.Cells(i + 2, j + 22)
For k = 1 To j - 1
If Not Ta(i, j) > Ta(i, k) Then MsgBox "Anomalie : doublon ou mauvais rangement en ligne " & (i + 2): Exit Sub
Next k
Next j, i
ReDim Tb(1 To NbC, NbB)
For i = 1 To NbC
For j = 1 To Lg
M = 0
R = 1
For k = 1 To NbB
For h = R To Co
If Tc(i, k) = Ta(j, h) Then M = M + 1: R = h + 1: Exit For
Next h
Next k
Tb(i, M) = Tb(i, M) + 1
Next j
Next i
Erase Tc
w.Range(w.Cells(3, 12), w.Cells(2 + NbC, 11 + NbB + 1)) = Tb
End Sub
'----------------------------------------------------------------------------------------------------------------
'Nombre de combinaisons de b éléments pris parmis a éléments*****************************************************
'Input : a, b****************************************************************************************************
'----------------------------------------------------------------------------------------------------------------
Function CmbNb(ByVal a&, ByVal b&) As Variant
Dim c&
On Error GoTo ErrTrp
If Not a < 0 And Not b < 0 And Not b > a Then
c = a - b
If c = 0 Then
CmbNb = 1
Else
If b < c Then c = b
CmbNb = FactLim(a, c) / FactLim(c)
End If
Else
CmbNb = CVErr(xlErrNum)
End If
Exit Function
ErrTrp:
On Error GoTo 0
CmbNb = CVErr(xlErrNum)
End Function
'----------------------------------------------------------------------------------------------------------------
'Factorielle de Lg***********************************************************************************************
'Option : limiter le nombre d'itérations*************************************************************************
'----------------------------------------------------------------------------------------------------------------
Function FactLim(ByVal Lg&, Optional NbIter) As Variant
Dim i&, n&
On Error GoTo ErrTrp
If Not Lg < 0 Then
If Not IsMissing(NbIter) Then n = CLng(NbIter) Else n = Lg
If n > Lg Or n < 0 Then
GoTo ErrTrp
Else
FactLim = 1
If Lg > 0 Then
For i = 0 To n - 1: FactLim = FactLim * (Lg - i): Next i
End If
End If
Else
FactLim = CVErr(xlErrNA)
End If
Exit Function
ErrTrp:
On Error GoTo 0
FactLim = CVErr(xlErrNum)
End Function
'----------------------------------------------------------------------------------------------------------------
'combinaisons b parmi a******************************************************************************************
'Input : longs***************************************************************************************************
'Output : tableau long*******************************************************************************************
'Rem : taille max varie selon systèmes, si erreur ubound(t)=0****************************************************
'----------------------------------------------------------------------------------------------------------------
Function CmbTab(ByVal a&, ByVal b&) As Long()
Dim n&, t&(), c&, i&, j&, v As Variant
If Not a < 1 And Not b < 1 And Not b > a Then
On Error GoTo ErrTrp
n = CLng(CmbNb(a, b))
ReDim t(1 To n, 1 To b)
c = a - b
For i = 1 To b
t(1, i) = i
Next i
For i = 2 To n
If b = 1 Then t(i, 1) = t(i - 1, 1) - (b = 1) Else t(i, 1) = t(i - 1, 1) + (t(i - 1, 2) = c + 2) * (b <> 1)
For j = 2 To b - 1
If t(i - 1, j + 1) = c + j + 1 Then
If t(i - 1, j) = c + j Then t(i, j) = t(i, j - 1) + 1 Else t(i, j) = t(i - 1, j) + 1
Else
t(i, j) = t(i - 1, j)
End If
Next j
If t(i - 1, b) = a Then t(i, b) = t(i, b - 1) + 1 Else t(i, b) = t(i - 1, b) + 1
Next i
CmbTab = t
Else
ErrTrp:
On Error GoTo 0
ReDim t(0)
CmbTab = t
End If
'End Function
'tri plage B3:O1142 colonne O ordre croissant
Range("B3:O1142").Select
ActiveWorkbook.Worksheets("combi").Sort.SortFields.Clear
ActiveWorkbook.Worksheets("combi").Sort.SortFields.Add Key:=Range("O3:O1142"), _
SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:=xlSortNormal
With ActiveWorkbook.Worksheets("combi").Sort
.SetRange Range("B3:O1142")
.Header = xlGuess
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
'copie données B3:O..mettre un critere pour prendre que les données colonne O superieur a 70
Vligne = Range("A65536").End(xlUp).Row
Vligne = Vligne + 1
Range("B3:O6").Select
Selection.Copy
Sheets("grille3").Select
Range("A1").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
'Range("A1").Select
'Sheets("Feuil1").Select
Application.CutCopyMode = False
'Sheets("Feuil1").Move After:=Sheets(3)
Sheets("combi").Select
'efface ligne W3:AP3 et remonte la plage en ligne 3
Range("W3:AP3").Select
Selection.ClearContents
Range("W4:AP112").Select
ActiveWindow.SmallScroll Down:=-90
Selection.Cut Destination:=Range("W3:AP111")
Range("A8").Select
End Function
Bonjour gmb, le forum
Merci pour ta réponse mais le résultat de la copie dans la feuille"grille3" n'est pas bonne.
En effet elle copie que les 4 dernieres colonnes alors qu'elle devrait copier aussi les 3 premiere colonnes
qui correspondent au 4 autres, c'est a dire B3:O6.
de plus si c'etait possible de ne pas copier toutes les lignes(B3:O1142) mais seulement celles qui ont comme résultat
en colonne O, egal ou + grand que 70.
merci
a+