Salut FabVBA,
comme ceci ?
Toujours un double-clic pour démarrer la macro qui crée une feuille 'Extract' pour l'affichage des résultats.
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
'
Dim iRow1%, iRow2%, iRowMAX%, iRowB%, iRowT%, lgNum#, sCol$
'
Application.ScreenUpdating = False
If Sheets(Sheets.Count).Name <> "Extract" Then Worksheets.Add(after:=Sheets(Sheets.Count)).Name = "Extract"
'
iRowB = Range("B" & Rows.Count).End(xlUp).Row
sCol = Split(Columns(Cells(1, Columns.Count).End(xlToLeft).Column).Address(ColumnAbsolute:=False), ":")(1)
iRowMAX = WorksheetFunction.Max(Range("A" & Rows.Count).End(xlUp).Row, Range("I" & Rows.Count).End(xlUp).Row, Range("Z" & Rows.Count).End(xlUp).Row)
Cancel = True
'
With Worksheets("Extract")
.Cells.Delete
.Range("A1:" & sCol & 1).Value = Range("A1:" & sCol & 1).Value
Do
iRow1 = IIf(iRow1 = 0, 2, iRow2 + 1)
iRow2 = IIf(iRow1 = iRowB, iRowMAX, Range("B" & iRow1).End(xlDown).Row - 1)
iRowT = IIf(iRow1 = 2, 2, WorksheetFunction.Max(.Range("A" & Rows.Count).End(xlUp).Row, .Range("I" & Rows.Count).End(xlUp).Row, .Range("Z" & Rows.Count).End(xlUp).Row) + 3)
.Range("A" & iRowT & ":" & sCol & iRowT + (iRow2 - iRow1)).Value = Range("A" & iRow1 & ":" & sCol & iRow2).Value
.Range("A" & iRowT & ":Y" & iRowT + (iRow2 - iRow1)).SpecialCells(xlCellTypeBlanks).Delete shift:=xlUp
lgNum = CLng(.Range("A" & iRowT).Value)
.Range("A" & iRowT & ":A" & iRowT + (iRow2 - iRow1)).Value = ""
.Range("A" & iRowT & ":A" & WorksheetFunction.Max(.Range("I" & Rows.Count).End(xlUp).Row, .Range("Z" & Rows.Count).End(xlUp).Row)).Value = lgNum
Loop Until iRow1 = iRowB
.Columns.AutoFit
.Activate
End With
'
Application.ScreenUpdating = True
'
End Sub
A+