Version Feuilles (refait dans un nouveau classeur, plus de bug).
http://cjoint.com/?iAod6mD0hB
Sub aaGenerSh()
Dim i As Long, Sh As Worksheet, j As Long
Application.ScreenUpdating = False
Application.DisplayAlerts = False
For Each Sh In ThisWorkbook.Sheets
Select Case Sh.CodeName
Case "Feuil1", "Feuil2", "Feuil3"
'on fait rien
Case Else
Sh.Delete
End Select
Next Sh
Application.DisplayAlerts = True
For i = 4 To 166
Feuil1.Copy before:=Sheets("Fin")
With ActiveSheet
.Name = Left(.Cells(2, i), 31)
Application.StatusBar = .Name
For j = 166 To 4 Step -1
If j <> i Then .Columns(j).EntireColumn.Delete
Next j
Range("A2:D41").Sort Key1:=Range("D3"), Order1:=xlDescending, Header:=
_
xlGuess, OrderCustom:=1, MatchCase:=False,
Orientation:=xlTopToBottom, _
DataOption1:=xlSortNormal
.[8:36].EntireRow.Delete
.[8:8].EntireRow.Insert
End With
Next i
Application.ScreenUpdating = True
Application.StatusBar = False
End Sub
Version Feuilles (refait dans un nouveau classeur, plus de bug).
http://cjoint.com/?iAod6mD0hB
Sub aaGenerSh() Dim i As Long, Sh As Worksheet, j As Long
Application.ScreenUpdating = False Application.DisplayAlerts = False For Each Sh In ThisWorkbook.Sheets Select Case Sh.CodeName Case "Feuil1", "Feuil2", "Feuil3" 'on fait rien Case Else Sh.Delete End Select Next Sh Application.DisplayAlerts = True
For i = 4 To 166
Feuil1.Copy before:=Sheets("Fin") With ActiveSheet .Name = Left(.Cells(2, i), 31) Application.StatusBar = .Name For j = 166 To 4 Step -1 If j <> i Then .Columns(j).EntireColumn.Delete Next j Range("A2:D41").Sort Key1:=Range("D3"), Order1:=xlDescending, Header: = _ xlGuess, OrderCustom:=1, MatchCase:úlse, Orientation:=xlTopToBottom, _ DataOption1:=xlSortNormal .[8:36].EntireRow.Delete .[8:8].EntireRow.Insert End With Next i Application.ScreenUpdating = True Application.StatusBar = False End Sub
'LSteph
re
On 26 août, 14:07, LSteph <gmlst...@gmail.com> wrote:
Bonjour,
Version Feuilles (refait dans un nouveau classeur, plus de bug).
http://cjoint.com/?iAod6mD0hB
Sub aaGenerSh()
Dim i As Long, Sh As Worksheet, j As Long
Application.ScreenUpdating = False
Application.DisplayAlerts = False
For Each Sh In ThisWorkbook.Sheets
Select Case Sh.CodeName
Case "Feuil1", "Feuil2", "Feuil3"
'on fait rien
Case Else
Sh.Delete
End Select
Next Sh
Application.DisplayAlerts = True
For i = 4 To 166
Feuil1.Copy before:=Sheets("Fin")
With ActiveSheet
.Name = Left(.Cells(2, i), 31)
Application.StatusBar = .Name
For j = 166 To 4 Step -1
If j <> i Then .Columns(j).EntireColumn.Delete
Next j
Range("A2:D41").Sort Key1:=Range("D3"), Order1:=xlDescending, Header: =
_
xlGuess, OrderCustom:=1, MatchCase:=False,
Orientation:=xlTopToBottom, _
DataOption1:=xlSortNormal
.[8:36].EntireRow.Delete
.[8:8].EntireRow.Insert
End With
Next i
Application.ScreenUpdating = True
Application.StatusBar = False
End Sub
Version Feuilles (refait dans un nouveau classeur, plus de bug).
http://cjoint.com/?iAod6mD0hB
Sub aaGenerSh() Dim i As Long, Sh As Worksheet, j As Long
Application.ScreenUpdating = False Application.DisplayAlerts = False For Each Sh In ThisWorkbook.Sheets Select Case Sh.CodeName Case "Feuil1", "Feuil2", "Feuil3" 'on fait rien Case Else Sh.Delete End Select Next Sh Application.DisplayAlerts = True
For i = 4 To 166
Feuil1.Copy before:=Sheets("Fin") With ActiveSheet .Name = Left(.Cells(2, i), 31) Application.StatusBar = .Name For j = 166 To 4 Step -1 If j <> i Then .Columns(j).EntireColumn.Delete Next j Range("A2:D41").Sort Key1:=Range("D3"), Order1:=xlDescending, Header: = _ xlGuess, OrderCustom:=1, MatchCase:úlse, Orientation:=xlTopToBottom, _ DataOption1:=xlSortNormal .[8:36].EntireRow.Delete .[8:8].EntireRow.Insert End With Next i Application.ScreenUpdating = True Application.StatusBar = False End Sub