Fusionner 2 modules

Option Explicit

Public Const WSBase As String = 'Feuille D2'
Sub D2_A()
Dim Rangebase As String
Dim RangeCount As String
Dim RangeCopy As String
Dim RowCopy As Integer
Dim i As Byte

For i = 1 To 4

Select Case i
Case 1
Rangebase = 'C2'
RangeCount = 'D58'
RangeCopy = 'B5'
RowCopy = 4
Case 2
Rangebase = 'C10'
RangeCount = 'D1316'
RangeCopy = 'B13'
RowCopy = 12
Case 3
Rangebase = 'C18'
RangeCount = 'D2124'
RangeCopy = 'B21'
RowCopy = 20
Case 4
Rangebase = 'C26'
RangeCount = 'D2932'
RangeCopy = 'B29'
RowCopy = 28
End Select


Equipe Rangebase, RangeCount, RangeCopy, RowCopy
Next i

End Sub



Sub Equipe(Rangebase As String, RangeCount As String, RangeCopy As String, RowCopy As Integer)
Dim Nom As String
Dim Lig1 As Integer, Lig2 As Integer
Dim i As Integer


Application.ScreenUpdating = False
With Sheets(WSBase).Range(Rangebase)
If InStr(1, .Value, ' ') < 1 Then Exit Sub
Nom = Left(.Value, InStr(1, .Value, ' ') + 1) + '.'
Nom = Application.WorksheetFunction.Proper(Nom)
End With

With Sheets(Nom)
Lig1 = .Range('A10000').End(xlUp).Row
Range(.Range('H' & Lig1 + 1), .Range('H' & Lig1 + 3)).Clear
End With

With Sheets(WSBase)
i = Application.CountA(.Range(RangeCount))
.Range(RangeCopy & ':I' & RowCopy + i).Copy
End With

With Sheets(Nom)
.Range('A65536').End(xlUp).Offset(1, 0).PasteSpecial Paste:=xlPasteFormats
.Range('A65536').End(xlUp).Offset(1, 0).PasteSpecial Paste:=xlPasteValues
Range(.Range('A4'), .Range('H' & Lig1)).Validation.Delete
Lig1 = .Range('A65536').End(xlUp).Row
Lig2 = .Range('J65536').End(xlUp).Row + 1
.Range('A4:H' & Lig1).Validation.Delete
Range(.Range('A4'), .Range('H' & Lig1)).Sort Key1:=.Range('A4'), Order1:=xlAscending
Range(.Range('J' & Lig2 - 1), .Range('M' & Lig2 - 1)).AutoFill _
Destination:=Range(.Range('J' & Lig2 - 1), .Range('M' & Lig1)), Type:=xlFillDefault
End With

Sheets('D2').Activate
Range('C5').Select

Application.ScreenUpdating = True
End Sub

Cliquez pour agrandir...

Option Explicit

Public Const WSBase As String = 'Feuille D2'
Sub D2_X()
Dim Rangebase As String
Dim RangeCount As String
Dim RangeCopy As String
Dim RowCopy As Integer
Dim i As Byte

For i = 1 To 4

Select Case i
Case 1
Rangebase = 'C34'
RangeCount = 'D3740'
RangeCopy = 'B37'
RowCopy = 36
Case 2
Rangebase = 'C42'
RangeCount = 'D4548'
RangeCopy = 'B45'
RowCopy = 44
Case 3
Rangebase = 'C50'
RangeCount = 'D5356'
RangeCopy = 'B53'
RowCopy = 52
Case 4
Rangebase = 'C58'
RangeCount = 'D6164'
RangeCopy = 'B61'
RowCopy = 60
End Select


Equipe Rangebase, RangeCount, RangeCopy, RowCopy
Next i

End Sub



Sub Equipe(Rangebase As String, RangeCount As String, RangeCopy As String, RowCopy As Integer)
Dim Nom As String
Dim Lig1 As Integer, Lig2 As Integer
Dim i As Integer


Application.ScreenUpdating = False
With Sheets(WSBase).Range(Rangebase)
If InStr(1, .Value, ' ') < 1 Then Exit Sub
Nom = Left(.Value, InStr(1, .Value, ' ') + 1) + '.'
Nom = Application.WorksheetFunction.Proper(Nom)
End With

With Sheets(Nom)
Lig1 = .Range('A10000').End(xlUp).Row
Range(.Range('H' & Lig1 + 1), .Range('H' & Lig1 + 3)).Clear
End With

With Sheets(WSBase)
i = Application.CountA(.Range(RangeCount))
.Range(RangeCopy & ':I' & RowCopy + i).Copy
End With

With Sheets(Nom)
.Range('A65536').End(xlUp).Offset(1, 0).PasteSpecial Paste:=xlPasteFormats
.Range('A65536').End(xlUp).Offset(1, 0).PasteSpecial Paste:=xlPasteValues
Range(.Range('A4'), .Range('H' & Lig1)).Validation.Delete
Lig1 = .Range('A65536').End(xlUp).Row
Lig2 = .Range('J65536').End(xlUp).Row + 1
.Range('A4:H' & Lig1).Validation.Delete
Range(.Range('A4'), .Range('H' & Lig1)).Sort Key1:=.Range('A4'), Order1:=xlAscending
Range(.Range('J' & Lig2 - 1), .Range('M' & Lig2 - 1)).AutoFill _
Destination:=Range(.Range('J' & Lig2 - 1), .Range('M' & Lig1)), Type:=xlFillDefault
End With

Sheets('D2').Activate
Range('C38').Select

Application.ScreenUpdating = True
End Sub

Cliquez pour agrandir...