1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54
| Sub Transfert()
Dim a() As Variant, b() As Variant
Dim i As Long, j As Long, k As Long
Dim DL As Double
Dim WkR As Workbook
Application.ScreenUpdating = False
Set WkR = Workbooks.Open(Filename:="" & ThisWorkbook.Worksheets("Paramètres").Cells(6, 3) & "", WriteResPassword:="123456")
If Not (WkR.ReadOnly) Then
With ThisWorkbook.Worksheets("Test")
WkR.Worksheets("Test").AutoFilterMode = False
.AutoFilterMode = False
a = .Range("A1").CurrentRegion.Value
b = Application.Transpose(WkR.Worksheets("Test").Range("A1").CurrentRegion.Value)
For i = 2 To UBound(a, 1)
If Not IsError(Application.Match(a(i, 2), Application.Index(b(), 2, 0), 0)) Then
k = Application.Match(a(i, 2), Application.Index(b(), 2, 0), 0)
For j = 1 To 62
If b(j, k) = "" Or (b(j, k) <> "" And b(j, k) <> a(i, j)) Then
If b(j, k) <> "" And a(i, j) = "" Then
b(j, k) = b(j, k)
Else
If (j = 20 Or j = 27 Or j = 27 Or j = 34 Or j = 38 Or j = 61) And a(i, j) <> "" Then
b(j, k) = b(j, k) & " " & a(i, j) 'si comment on garde tout
Else
b(j, k) = a(i, j)
End If
End If
End If
Next j
Else
ReDim Preserve b(UBound(b, 1), UBound(b, 2) + 1)
For j = 1 To 62
b(j, UBound(b, 2)) = a(i, j)
Next j
End If
Next i
End With
With WkR.Worksheets("Test")
DL = .Cells(.Rows.Count, 2).End(xlUp).Row + 1
.Range("A1:BJ" & DL).ClearContents
.Range("A1").Resize(UBound(b, 2), UBound(b, 1)).Value = Application.Transpose(b())
.Range("A3:BJ" & DL).Sort Key1:=.Range("B3"), Order1:=xlAscending, Header:=xlGuess, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
.Range("A2:BJ2").AutoFilter
End With
WkR.Save
WkR.Close
Erase a
Erase b
Else
MsgBox "Le fichier récapitulatif est bloqué. Veuillez réessayer dans quelques minutes! Merci"
End If
Set WkR = Nothing
Application.ScreenUpdating = True
End Sub |
Partager