Option Explicit
Sub StsBar(ByVal strMsg As String)
Application.StatusBar = strMsg
End Sub
Sub traitement()
Dim h As Long, i As Long, j As Long
Dim strOps As String, strFormuleA As String
Application.ScreenUpdating = False
Sheets("1").Activate
Range("N2:AK50").ClearContents
strFormuleA = "=IF(AND(RC[-11]=R1C[2],RC[-10]=R1C[3],RC[-9]=R1C[4],RC[-8]=R1C[5],RC[-7]=R1C[6],RC[-6]=R1C[7],RC[-5]=R1C[8],RC[-4]=R1C[9],RC[-3]=R1C[10]),RC[-1],"""")"
Range("L2:L50").FormulaR1C1 = strFormuleA
For h = 0 To 13
Sheets("1").Activate
Range("N1:W1").Value = Range("A2:J2").Offset(h, 0).Value 'copie des données
If h >= 0 And h < 5 Then i = 6
If h > 4 And h < 10 Then i = 11
If h > 9 And h < 15 Then i = 16
j = i + 33
StsBar strOps & " h=" & h & " i=" & i & " j=" & j
Range("X1").Value = "=COUNTIF(R[" & i & "]C[-12]:R[" & j & "]C[-12],0)"
Range("Y1").Value = "=COUNTIF(R[" & i & "]C[-13]:R[" & j & "]C[-13],1)"
Range("N2:Y2").Offset(h, 0).Value = Range("N1:Y1").Value 'copie des résultats
Sheets("1").Range(Cells(i, 12), Cells(j, 12)).Copy
Sheets("2").Range("B1").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
supLignesRapide
Sheets("2").Range("B2:B11").Copy 'copie resultat feuille 2
Sheets("1").Range("AA2").Offset(h, 0).PasteSpecial xlPasteValues, , , True
Next
ActiveWorkbook.Save
Application.ScreenUpdating = True
End Sub
Sub supLignesRapide() 'suppression de lignes tres rapide
'supprime les lignes contenant "B" en colonne A
Dim c As Range
Dim strFormuleA As String
Sheets("2").Activate
strFormuleA = "=IF(RC[1]="""",""B"","""")"
Range("A2:A170").FormulaR1C1 = strFormuleA
With ActiveSheet
.Range("A1").CurrentRegion.Sort key1:=.Cells(2, 1), Order1:=xlAscending, Header:=xlYes
Set c = .Columns(1).Find(What:="B", LookIn:=xlValues)
If Not c Is Nothing Then
.Range(c, .Cells(.Rows.Count, 1).End(xlUp)).EntireRow.Delete xlShiftUp
End If
End With
End Sub