Bonjour,

j'ai un probleme actuellement avec un resize de ma plage pour coller un tableau. C'est trés surprenant et ca ressemble à une limitation.

J'ai déjà du faire face à une limitation avec la transposition, et j'ai créé la fonction transposition.
le probleme est dans le resize. on notera qu'il ya bien le bon nombre de ligne et de colonnes dans la plage, donc je ne comprend pas....
Je transpose des resultats que je souhaite coller dans une plage.Nom : Capture.PNG Affichages : 1259 Taille : 20,5 Ko

Code : Sélectionner tout - Visualiser dans une fenêtre à part
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
 
 
'fonction pour transposer un vecteur sans limitation de taille
Function TransposeV(ByRef MyTab)
    Dim i As Long, j As Long, More As Byte
    Dim MyTabTrans()
 
    'redimentionnement
    If LBound(MyTab) = 0 Then More = 1 Else More = 0
    ReDim Preserve MyTabTrans(1 To UBound(MyTab, 2) + More, 1 To UBound(MyTab) + More)
 
    'Echange Lignes ==> Colonnes
    For i = LBound(MyTab) To UBound(MyTab)
        For j = LBound(MyTab, 2) To UBound(MyTab, 2)
            MyTabTrans(j + More, i + More) = MyTab(i, j)
        Next j
    Next i
 
    'Attribution
    TransposeV = MyTabTrans
End Function
Code : Sélectionner tout - Visualiser dans une fenêtre à part
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
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
 
'Tableau complet des erreurs lors de l'integration dans la Base de données
Sub VectHdlErrOrAlerte(ByRef MyDico As Dictionary, Optional ByRef MyDicoID As Dictionary, Optional ByRef MyDicoDarCol As Dictionary, Optional ByVal MyDar As String, Optional ByVal Alerte As Boolean = False)
    Dim Rct As New ADODB.Recordset, strSQL As String, MyLast(), MyKeyID As String
    Dim MyDarStr As String, MyTabErr(), NbRow As Long, k As Long, MyNewID As String
    Dim i As Long, MyKey, MySelection As String, MyTab(), n As Long
 
    With ThisWorkbook.Worksheets("Errors_Details")
        'Nettoyage
        .Range(.Range("Start_Erreurs"), .Range("Start_Erreurs").End(xlDown).Offset(, 5)).ClearContents
        .Range(.Range("Start_Alertes"), .Range("Start_Alertes").End(xlDown).Offset(, 8)).ClearContents
    End With
 
    'si alerte mais pas de DAR histo ==> on le fait pas
    If Alerte Then
        'Last DAR
        MyDarStr = Format(LastDar(MyDar), "dd/mm/yyyy")
        If Not MyDicoDarCol.Exists(MyDarStr) Then Alerte = False
    End If
 
    'Nb clef
    If MyDico.Count > 0 Then
        NbRow = MyDico.Count
 
        'Redimentionner le tableau
        ReDim Preserve MyTabErr(NbRow, 5)
 
        'on parcours les references de clefs des erreurs
        i = 0
        For Each MyKey In MyDico.Keys
            'Attribution des valeurs ds un Tableau
            MyTabErr(i, 0) = MyDico(MyKey).MyETB: MyTabErr(i, 1) = MyDico(MyKey).MyID
            MyTabErr(i, 2) = MyDico(MyKey).MyPb: MyTabErr(i, 3) = MyDico(MyKey).MyReport
            MyTabErr(i, 4) = MyDico(MyKey).MySheet: MyTabErr(i, 5) = "'" & MyDico(MyKey).MyFunction
            i = i + 1
        Next MyKey
 
        'Attribution
        With ThisWorkbook.Worksheets("Errors_Details")
 
            'copy des erreurs
            .Range("Start_Erreurs").Resize(UBound(MyTabErr) + 1, UBound(MyTabErr, 2) + 1).Value = MyTabErr
        End With
    End If
 
    If Alerte Then
        'Requete pour selectionner les ID avec un Historique (donc <>0)
        strSQL = "SELECT [ETB],[ID],([" & MyDar & "]-[" & MyDarStr & "])/[" & MyDarStr & "],[" & MyDar & "],[" & MyDarStr & "] FROM [Base_Donnee$] WHERE [" & MyDarStr & "] <> 0 AND [ID]<>'Format' AND [TypeD]='ETB' "
        Rct.Open strSQL, myConnection, adOpenDynamic, adLockPessimistic
        'copier les alertes
        If Not Rct.EOF Then
            MyTab = Application.WorksheetFunction.Transpose(Rct.GetRows)
            For i = LBound(MyTab) To UBound(MyTab)
 
                'ID from la base de donnees
                MyKeyID = Mid(MyTab(i, 2), InStr(MyTab(i, 2), "__") + 2)
                If MyDicoID.Exists(MyKeyID) Then
                    If Abs(CDbl(MyTab(i, 3))) > MyDicoID(MyKeyID).MyNorme Then
                        k = k + 1
                        ReDim Preserve MyLast(1 To 9, 1 To k)
                        For n = 1 To 5
                            MyLast(n, k) = MyTab(i, n)
                        Next n
                        MyNewID = Mid(MyTab(i, 2), InStr(MyTab(i, 2), "__") + 2, Len(MyTab(i, 2)) - InStr(MyTab(i, 2), "__") + 2)
                        MyLast(6, k) = MyDicoID(MyNewID).MyNorme
                        MyLast(7, k) = MyDicoID(MyNewID).MyReport
                        MyLast(8, k) = MyDicoID(MyNewID).MySheet
                        MyLast(9, k) = MyDicoID(MyNewID).MyFunction
                    End If
                End If
            Next i
 
 
            'copy des variations alertes si il y'en a
            If Not IsEmpty_V(MyLast) Then
                With ThisWorkbook.Worksheets("Errors_Details")
 
                    .Range("Start_Alertes").Resize(UBound(MyLast,2), UBound(MyLast)) = TransposeV(MyLast)
                End With
            End If
        End If
    End If
 
    'MAJ des indicateurs "Nb erreurs et Nb Alertes"
    ThisWorkbook.Worksheets("Errors_Details").Calculate
    Set Rct = Nothing
End Sub