| 12
 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