bonjour le forum
j'ai une macro qui s'exécute a la suite mais seul le premier couplé est correct. La macro prend en BN2:BO2 les donnés est les inscrit en U1:V1, hors quand j'exécute le code pas a pas arrivé a la partie 'extraire' la plage de données est vide donc il semblerait que le deuxieme couplé n'a pas été inscrit en U1:V1. Le partie du code ou il y aurait l'erreur est celui-ci
voici le code en entier
Quel est la bonne formulation a inscrire.
merci
j'ai une macro qui s'exécute a la suite mais seul le premier couplé est correct. La macro prend en BN2:BO2 les donnés est les inscrit en U1:V1, hors quand j'exécute le code pas a pas arrivé a la partie 'extraire' la plage de données est vide donc il semblerait que le deuxieme couplé n'a pas été inscrit en U1:V1. Le partie du code ou il y aurait l'erreur est celui-ci
Code:
'ajoute 2eme couplé col BN:BO a U1:V1
Range("U1:V1").Value = Range("BN" & Ligne & ":BO" & Ligne).Value
ActiveSheet.Calculate
Code:
Sub Macro_Atester()
Dim Ligne As Long, Indice As Long
'efface la BdD Y:AR
Worksheets("Feuil1").Select
For Ligne = 2 To Range("BN" & Rows.Count).End(xlUp).Row
Range("Y2:AR3012").ClearContents
'ajoute 2eme couplé col BN:BO a U1:V1
Range("U1:V1").Value = Range("BN" & Ligne & ":BO" & Ligne).Value
ActiveSheet.Calculate
'extraire les lignes de A:T a Y2
Dim I&, Fin&, aa, bb, y&, a&
With Feuil1
Fin = .Range("A" & Rows.Count).End(xlUp).Row
aa = .Range("A2:W" & Fin)
End With
y = 1
ReDim bb(UBound(aa, 2), y)
For I = 1 To UBound(aa) - 1
If aa(I + 1, 22) = 1 Then
ReDim Preserve bb(UBound(aa, 2), y)
For a = 1 To UBound(aa, 2) - 3
bb(a, y) = aa(I, a)
Next a
y = y + 1
End If
Next I
Range("Y2").Resize(UBound(bb, 2), UBound(bb)) = Application.Transpose(bb)
'Sub Combinaison()
Dim D As Integer, K As Integer, L As Integer, M As Integer
Dim NbMax As Integer
Dim Tablo(1 To 70, 1 To 70, 1 To 70, 1 To 70) As Integer
Dim J As Long
Dim Resultat(1 To 1, 1 To 5)
Dim Tbl1
Dim Nombre As Integer
Application.ScreenUpdating = False
Tbl1 = Range("Feuil1!BdD")
NbMax = UBound(Tbl1, 2)
For J = 1 To UBound(Tbl1)
For D = 1 To NbMax - 3
For K = D + 1 To NbMax - 2
For L = K + 1 To NbMax - 1
For M = L + 1 To NbMax
Tablo(Tbl1(J, D), Tbl1(J, K), Tbl1(J, L), Tbl1(J, M)) = Tablo(Tbl1(J, D), Tbl1(J, K), Tbl1(J, L), Tbl1(J, M)) + 1
Next M
Next L
Next K
Next D
Next J
Range("AW2:BG" & Rows.Count).ClearContents
Indice = 0
For D = 1 To 70
For K = 1 To 70
For L = 1 To 70
For M = 1 To 70
If Tablo(D, K, L, M) > 0 Then
Indice = Indice + 1
Resultat(1, 1) = D
Resultat(1, 2) = K
Resultat(1, 3) = L
Resultat(1, 4) = M
Resultat(1, 5) = Tablo(D, K, L, M)
Cells(1 + Indice, "AW").Resize(1, 5) = Resultat
End If
'End If
Next M
Next L
Next K
Next D
Range("AW2:BA" & Indice + 1).Copy
Range("BC2").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
With ActiveSheet.Sort
.SortFields.Clear
.SortFields.Add Key:=Range("BG2:BG" & Indice + 1), SortOn:=xlSortOnValues, _
Order:=xlDescending, DataOption:=xlSortNormal
.SetRange Range("BC2:BG" & Indice + 1)
.Header = xlGuess
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
'tri BC:BF
For J = 2 To 23
Range("BC" & J).Resize(1, 4).Copy
Cells(2 + ((J - 2) * 4), "BJ").PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:=False, Transpose:=True
Next J
'fin tri BC:BF
Range("$BJ$2:$BJ$89").RemoveDuplicates Columns:=1, Header:=xlNo
'colonne BJ rangée en BP
Dim vLigne As Long
vLigne = Range("BP65536").End(xlUp).Row + 1
If vLigne < 2 Then vLigne = 2
Range("BJ2:BJ26").Copy
Range("BP" & vLigne).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=True
Next Ligne
Range("Y2:AR3012").ClearContents
Range("AW2:BG" & Rows.Count).ClearContents
Application.CutCopyMode = False
Columns("BP:CN").EntireColumns.AutoFit
Range("AT1").Offset(I, 0).Select
Call Macro_Atester
End Sub
merci