Bonjour,
Une solution avec le code suivant à copier dans un module Standard.
Sub ImprMultiSelect()
Dim var
Dim i&
Dim deb&
Dim cpt&
Dim A$
Dim B$
Dim nbChamp&
Dim Add$()
Dim S As Worksheet
Dim S2 As Worksheet
Dim R As Range
On Error GoTo Erreur
Application.ScreenUpdating = False
Set S = ActiveSheet
A$ = Selection.Address
nbChamp& = 1
For i& = 1 To Len(A$)
If Mid(A$, i&, 1) = "," Then nbChamp& = nbChamp& + 1
Next i&
If nbChamp& = 1 Then Exit Sub
ReDim Preserve Add$(1 To nbChamp&)
deb& = 1
cpt& = 1
For i& = 1 To Len(A$)
B$ = Mid(A$, i&, 1)
If B$ <> "," Then
Add$(cpt&) = Add$(cpt&) & B$
Else
deb& = Len(Add$(cpt&)) + 1
cpt& = cpt& + 1
End If
Next i&
ActiveSheet.Copy before:=Sheets(ActiveSheet.Name)
Set S2 = ActiveSheet
With S2.Cells
.ClearContents
.Interior.ColorIndex = xlNone
For i& = 5 To 12
.Borders(i&).LineStyle = xlNone
Next i&
End With
For i& = 1 To nbChamp&
var = S.Range(Add$(i&))
S2.Range(Add$(i&)) = var
Next i&
For i& = 1 To nbChamp&
Set R = S.Range(Add$(i&))
R.Copy
S2.Range(Add$(i&)).Select
Selection.PasteSpecial Paste:=xlPasteFormats
Next i&
S2.PageSetup.PrintArea = ""
S2.PrintPreview
'--- On supprime éventuellement la copie (contenant les sélections multiples) ---
'--- Si vous voulez visualisez la feuille copie, quotez les 2 lignes suivantes ---
Application.DisplayAlerts = False
S2.Delete
'---------------------------------------------------------------------------------
Erreur:
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub