Resize et application.transpose(array)

Le 28/08/2018 à 13:22

Bonjour à vous,

voilà, je rencontre une erreur de type "Incompatibilité de type" avec cette macro sans parvenir après maints essais à en comprendre la cause.

La macro consiste à guider l'utilisateur dans la duplication de son fichier pour l'année suivante, avec selon son choix, le copier-coller des entrées dans son registre actuel correpondant à la date du registre N+1.

L'erreur apparait après le dernier stop, à la ligne suivante:

TargetWb.Sheets("Récapitulatif").Cells(2, 2).Resize(UBound(arrOldEntries, 2) + 1, UBound(arrOldEntries, 1)).Value = Application.Transpose(arrOldEntries)

Si l'un ou l'une d'entre vous en un coup d'oeil réussit à voir le problème, je suis bien sûr preneur.

Merci beaucoup.

Sub CreerNouveauRegistreAnneeSuivante()

    'Déclaration des variables
    Dim arrOldEntries(18, 2031) As Variant
    Dim TargetWb As Workbook
    Dim newYear As Variant
    Dim YearTargeted As Integer
    Dim newWbName As String
    Dim dateConsult, cell, derLigne As Range
    Dim incrementColonneTab, i, j As Integer
    Dim choix As Boolean

    'Désactivation du rafraichissement d'écran
    Application.ScreenUpdating = False

    'Attribution des valeurs
    Set dateConsult = Sheets("Récapitulatif").Range("C2:C2032")
    i = 0
    choix = False

    'Faire apparaitre une boite de dialogue pour préciser la prochaine année d'utilisation
    Do
        newYear = InputBox("Veuillez saisir la nouvelle année d'utilisation de votre registre.", "RENOUVELLEMENT REGISTRE POUR ANNEE ULTERIEURE", Year(Now()) + 1)
            If Not IsNumeric(newYear) And newYear <> "" Then
            MsgBox "Attention. Votre entrée contient un ou plusieurs caractères non numériques. Veuillez entrer l'année souhaitée sous forme de nombre"
            ElseIf newYear = "" Then
                Application.ScreenUpdating = True
                Exit Sub
            End If
    Loop While Not IsNumeric(newYear)
    newWbName = "Planning" & " " & Sheets("config").Range("F11").Value & " " & newYear

    'Choix de recopier où non les informations de l'ancien document correspondant à la nouvelle année
    If MsgBox("Importer les consultations " & newYear & " de votre registre actuel.", vbQuestion + vbYesNo, "RECOPIE DE VOS INFORMATIONS PREALABLES") = vbYes Then
        choix = True
        For Each cell In dateConsult
            YearTargeted = Year(Cells(cell.Row, COLUMN_DATE).Value)
                If YearTargeted = newYear Then
                    For incrementColonneTab = 0 To 17
                        arrOldEntries(incrementColonneTab, i) = Cells(cell.Row, incrementColonneTab + 2)
                    Next incrementColonneTab
                    i = i + 1
                End If
        Next
        'Vérification du tableau enregistré dans la fenêtre de débugger
        For i = 0 To UBound(arrOldEntries, 1) 'lignes
                  Debug.Print arrOldEntries(0, i) & " " & _
                            arrOldEntries(1, i) & " " & _
                            arrOldEntries(2, i) & " " & _
                            arrOldEntries(3, i) & " " & _
                            arrOldEntries(4, i) & " " & _
                            arrOldEntries(5, i) & " " & _
                            arrOldEntries(6, i) & " " & _
                            arrOldEntries(7, i) & " " & _
                            arrOldEntries(8, i) & " " & _
                            arrOldEntries(9, i) & " " & _
                            arrOldEntries(10, i) & " " & _
                            arrOldEntries(11, i) & " " & _
                            arrOldEntries(12, i) & " " & _
                            arrOldEntries(13, i) & " " & _
                            arrOldEntries(14, i) & " " & _
                            arrOldEntries(15, i) & " " & _
                            arrOldEntries(16, i) & " " & _
                            arrOldEntries(17, i)
        Next
    Else
    choix = False
    End If

Stop
        'Confirmation
        If MsgBox("Confirmez vous la création d'un nouveau fichier? Le fichier actuel sera simplement fermé et enregistré à son endroit habituel avant création de votre fichier" & " " & newYear & ". " & "Votre nouveau fichier sera enregistré dans le même emplacement que l'actuel sous l'appelation " & Chr(34) & newWbName & Chr(34) & ".", vbOKCancel + vbQuestion, "CONFIRMATION") = vbOK Then
                'Enregistrer le fichier actuel
                ThisWorkbook.Save
                'Enregistrer sous le nouveau fichier
                newPath = ThisWorkbook.Path & "/" & newWbName
                ThisWorkbook.SaveAs (newPath)
                Set TargetWb = Workbooks(newWbName)
                'Effacer tout
                TargetWb.Sheets("Récapitulatif").Activate
                TargetWb.Sheets("Récapitulatif").Unprotect
                TargetWb.Sheets("Récapitulatif").Range(Cells(2, COLUMN_TYPE), Cells(2032, COLUMN_PLURI)).ClearContents
                TargetWb.Sheets("Récapitulatif").Protect
                'Si le premier choix d'importer les consultations était positif
                    If choix = True Then
                        'Coller le tableau
Stop
                        TargetWb.Sheets("Récapitulatif").Unprotect
                        TargetWb.Sheets("Récapitulatif").Cells(2, 2).Resize(UBound(arrOldEntries, 2) + 1, UBound(arrOldEntries, 1)).Value = Application.Transpose(arrOldEntries)
                        TargetWb.Sheets("Récapitulatif").Protect
                        Application.ScreenUpdating = True
                        TargetWb.Sheets("Récapitulatif").Range("b2").Activate
                    Else
                        'Retour à la dernière ligne et rafraichissement
                        Application.ScreenUpdating = True
                        TargetWb.Sheets("Récapitulatif").Range("b2").Activate
                    End If
        Else: Exit Sub
        End If

End Sub
Le 28/08/2018 à 19:20

Bonjour,

Evites le Resize et teste de cette façon :

With TargetWb.Sheets("Récapitulatif")
    .Range(.Cells(2, 2), .Cells(UBound(arrOldEntries, 2) + 1, UBound(arrOldEntries, 1))).Value = Application.Transpose(arrOldEntries)
End With

où .Cells(2, 2) est la cellule en haut à gauche et .Cells(UBound(arrOldEntries, 2) + 1, UBound(arrOldEntries, 1)) est la cellule en bas à droite de la plage

Le 30/08/2018 à 11:34

Merci Thézé,

bon. J'ai beau tourner le code dans tous les sens, avec ta proposition bien sur, et une erreur "incompatbilité de type" résiste. Etonnament, lorsque le tableau gère deux lignes, cela fonctionne, et lorsqu'il y a plusieurs centaines de lignes cela échoue.

J'ai réécrit une part du code.

Si jamais tu as une idée, je suis preneur, mais ne t'embête pas outre mesure, je pense que je vais renoncer à créer cette fonction si la difficultés traîne trop longtemps...

Merci pour ton aide.

Option Explicit

'Les intitulés COLUMN_NOMCOLONNE sont des constantes déclarées dans le module AFFECTATION_CONSTANTES.
'Cela permet d'en mofifier d'un coup les occurences dans le projet lorsqu'une colonne est ajouté ou supprimée du registre.
Sub CreerNouveauRegistreAnneeSuivante()

    'Déclaration des variables
    Dim arrOldEntries() As Variant
    Dim TargetWb As Workbook
    Dim newYear As Variant
    Dim newWbName, newPath As String
    Dim dateConsult, cell, derLigne As Range
    Dim YearTargeted, incrementColonneTab, i, k As Integer
    Dim choix As Boolean

    'Dimensionnement du tableau au nombre maximal de consultations à enregistrer possibles
    ReDim Preserve arrOldEntries(18, 2031)

    'Désactivation du rafraichissement d'écran
    Application.ScreenUpdating = False

    'Attribution des valeurs
    Set dateConsult = Sheets("Récapitulatif").Range("C2:C2032")
    i = 0
    choix = False

    'Faire apparaitre une boite de dialogue pour préciser la prochaine année d'utilisation
    Do
        newYear = InputBox("Veuillez saisir la nouvelle année d'utilisation de votre registre.", "RENOUVELLEMENT REGISTRE POUR ANNEE ULTERIEURE", Year(Now()) + 1)
            If Not IsNumeric(newYear) And newYear <> "" Then
            MsgBox "Attention. Votre entrée contient un ou plusieurs caractères non numériques. Veuillez entrer l'année souhaitée sous forme de nombre"
            ElseIf newYear = "" Then
                Application.ScreenUpdating = True
                Exit Sub
            End If
    Loop While Not IsNumeric(newYear)
    newWbName = "Planning" & " " & Sheets("config").Range("F11").Value & " " & newYear

    'Choix de recopier où non les informations de l'ancien document correspondant à la nouvelle année
    If MsgBox("Souhaitez-vous importer les consultations " & newYear & " ici présentes dans votre nouveau fichier?", vbQuestion + vbYesNo, "RECOPIE DE VOS INFORMATIONS PREALABLES") = vbYes Then
        choix = True
        For Each cell In dateConsult
            YearTargeted = Year(Cells(cell.Row, COLUMN_DATE).Value)
                If YearTargeted = CInt(newYear) Then
                    For incrementColonneTab = 0 To 17
                        arrOldEntries(incrementColonneTab, i) = Cells(cell.Row, incrementColonneTab + 2)
                    Next incrementColonneTab
                    i = i + 1
                End If
        Next

        'Redimensionnement du tableau au nombre des consultations enregistrées
        ReDim Preserve arrOldEntries(18, i)

        'Vérification du tableau enregistré dans la fenêtre de débugger
        For k = 0 To i - 1 'lignes
                  Debug.Print arrOldEntries(0, k) & " " & _
                            arrOldEntries(1, k) & " " & _
                            arrOldEntries(2, k) & " " & _
                            arrOldEntries(3, k) & " " & _
                            arrOldEntries(4, k) & " " & _
                            arrOldEntries(5, k) & " " & _
                            arrOldEntries(6, k) & " " & _
                            arrOldEntries(7, k) & " " & _
                            arrOldEntries(8, k) & " " & _
                            arrOldEntries(9, k) & " " & _
                            arrOldEntries(10, k) & " " & _
                            arrOldEntries(11, k) & " " & _
                            arrOldEntries(12, k) & " " & _
                            arrOldEntries(13, k) & " " & _
                            arrOldEntries(14, k) & " " & _
                            arrOldEntries(15, k) & " " & _
                            arrOldEntries(16, k) & " " & _
                            arrOldEntries(17, k)
        Next
    Else
    choix = False
    End If
Stop
        'Confirmation
        If MsgBox("Confirmez vous la création d'un nouveau fichier? Le fichier actuel sera simplement fermé et enregistré à son endroit habituel avant création de votre fichier" & " " & newYear & ". " & "Votre nouveau fichier sera enregistré dans le même emplacement que l'actuel sous l'appelation " & Chr(34) & newWbName & Chr(34) & ".", vbOKCancel + vbQuestion, "CONFIRMATION") = vbOK Then
                'Enregistrer le fichier actuel
                ThisWorkbook.Save
                'Enregistrer-sous le nouveau fichier
                newPath = ThisWorkbook.Path & "/" & newWbName
                ThisWorkbook.SaveAs (newPath)
                Set TargetWb = Workbooks(newWbName)
                'Effacer tout
                With TargetWb.Sheets("Récapitulatif")
                    .Activate
                    .Unprotect
                    .Range(Cells(2, COLUMN_TYPE), Cells(2032, COLUMN_PLURI)).ClearContents
                    .Protect
                End With
                    If choix = True Then                    'Si le premier choix d'importer les consultations était positif alors recopier le tableau
Stop
                        With TargetWb.Sheets("Récapitulatif")
                            .Unprotect
                            .Range(.Cells(2, 2), .Cells(i + 2, 19)).Value = Application.Transpose(arrOldEntries)
                            .Protect
                             Application.ScreenUpdating = True
                            .Range("b2").Activate
                        End With
                    Else
                        Application.ScreenUpdating = True   'Rafraichissement
                        TargetWb.Sheets("Récapitulatif").Range("b2").Activate 'Retour à la dernière ligne
                    End If
        Else: Exit Sub
        End If

End Sub
Le 30/08/2018 à 11:59

Bonjour Theophile69,

tu a écrit :

Merci Thézé,

c'est pas Thézé mais Theze !

"à moins qu'ce soit lui :"
screen

ça, j'dois bien reconnaître que Theze alias Thésée est bien une des institutions du forum !

bravo Thésée ! (pour tes réponses et pour avoir vaincu le Minotaure ! )

dhany

Le 30/08/2018 à 12:19

Salut l'équipe,

... trop difficile sans fichier, même maigrelet...

A+

Le 30/08/2018 à 14:19

Bonjour tout le monde,

Effectivement, ce n'est pas "Thézé" mais Theze comme le fait justement remarquer dhany

Comme dit Currulis , sans fichier exemple pas facile de te venir en aide d'autant plus qu'il y a des contradictions comme par exemple ce double redimensionnement :

ReDim Preserve arrOldEntries(18, 2031)
'...
'...
ReDim Preserve arrOldEntries(18, i)

Je pense que le problème vient du remplissage du tableau mais je ne vais pas m'amuser à construire un classeur pour tester !

Le 30/08/2018 à 15:10

Bonjour à tous,

voici le fichier en pièce jointe.

1/ j'ai identifié tout d’abord que l'erreur "incompatibilité de type" vient d'un conflit entre la variant et du texte html (il me semble).

2/ J'ai remarqué que souvent lorsque le nouveau document se créé (un save-as du premier), la variable "i" est comme vide; comme si la boucle d'alimentation du tableau ne s'était pas bien déroulée.

3/simple question: comment gère Visual Basic Editor lorsqu'une macro commence dans un fichier puis est censée se poursuivre après un save-as dans le fichier suivant?

Oui le redim permet tout d'abord de fixer une taille au tableau dynamique, puis de le réduire à son strict nécessaire.

A vous lire (si vous ne trouvez rien, ne vous faites pas mal au crâne non plus).

6fichier-d-entrainement.zip (567.36 Ko)
Le 30/08/2018 à 16:12

@Theophile69

tu a écrit :

1/ j'ai identifié tout d’abord que l'erreur "incompatibilité de type" vient d'un conflit entre la variant et du texte html (il me semble).

attention de ne pas confondre une « variable » avec le type « variant » ! « conflit entre la variable et du texte html » : oui, c'est possible si le type de la variable n'est pas en adéquation avec du texte html ; par exemple : une variable d'un type numérique ne peut pas contenir du texte (html ou non) ; mais une variable de type « variant » peut contenir n'importe quoi, y compris du texte (html ou non).

bien sûr, une variable de type variant ne peut pas vraiment contenir n'importe quoi : même si elle accepte les objets, tu ne peux pas y stocker un éléphant ! (c'est pas ma faute, hein, si la contenance est pas assez grande !)

dhany

Le 31/08/2018 à 16:03

Bonjour,

oui, c'est bien pour cela que j'ai misé sur le type variant.

D'ailleurs, je sais que le contenu "litigieux" est un contenu HTML puisqu'il est directement importé du corps .html d'un mail Outlook, et pourtant le texte dans la cellule Excel ne fait apparaître rien de typique (balise ou caractère quelconque).

Se peut-il que des contenus .html soient invisibles dans une cellule?

Et dans ce cas, quelqu'un sait-il comment convertir ces bout de texte "contaminé" vers une variable string toute bête?

Merci

Le 31/08/2018 à 16:10

Bonjour,

vraiment à tout hasard, essaye avec CStr()

si ça marche : ok ; sinon, j'ai pas d'autre idée.

dhany

Le 31/08/2018 à 17:31

Salut Théo,

Salut l'équipe,

... ai chargé ton fichier et créé un nouvel agenda sans erreur.

Evidemment, il n'y a pas de données...

Débrouille-toi pour nous procurer un fichier avec des données à problème que l'on puisse y voir plus clair.

A+

Le 03/09/2018 à 10:39

Bonjour Curulis57,

merci pour ton intérêt.

j'ai placé un fichier plus parlant: il faut bien noter 2039 dans la inputbox qui demande la nouvelle année.

Tu verras, c'est la cellule O2 qui pose problème, là où j'ai une demande écrite que je pensais contenir du .html.

A te lire si tu en as le temps,

merci.

10fichier-d-entrainement.zip (567.36 Ko)
Le 03/09/2018 à 14:30

Bonjour,

Ton tableau est en base 0 et le Range en base 1 donc, avec application.Transpose() c'est un peu boiteux !

Afin d'éviter d'avoir recourt à Transpose(), il te faut dimensionner ton tableau de la bonne façon.

Voici ton code modifié et probablement à améliorer encore. Evites les noms de variables à rallonge si possible. Je ne comprends par pourquoi 2039 mais bon :

Sub CreerNouveauRegistreAnneeSuivante()

    'Déclaration des variables
    Dim Tbl() As String
    Dim TargetWb As Workbook
    Dim newYear As Variant
    Dim newWbName As String
    Dim newPath As String
    Dim PlgDate As Range
    Dim Cel As Range
    Dim Col As Integer
    Dim I As Long
    Dim choix As Boolean
    Dim J As Long

    'Désactivation du rafraichissement d'écran
    Application.ScreenUpdating = False

    'Faire apparaitre une boite de dialogue pour préciser la prochaine année d'utilisation
    Do
        newYear = InputBox("Veuillez saisir la nouvelle année d'utilisation de votre registre.", _
                           "RENOUVELLEMENT REGISTRE POUR ANNEE ULTERIEURE", Year(Now()) + 1)

        If Not IsNumeric(newYear) And newYear <> "" Then

            MsgBox "Attention. Votre entrée contient un ou plusieurs caractères non numériques. Veuillez entrer l'année souhaitée sous forme de nombre"

        ElseIf newYear = "" Then

            Application.ScreenUpdating = True: Exit Sub

        End If

    Loop While Not IsNumeric(newYear)

    With Worksheets("Récapitulatif"): Set PlgDate = .Range(.Cells(2, 3), .Cells(.Rows.Count, 3).End(xlUp)): End With

    'comptabilise les lignes
    For Each Cel In PlgDate

        If InStr(Cel.Text, newYear) <> 0 Then J = J + 1

    Next Cel

    If J = 0 Then MsgBox "Aucune date correspondantes !": Exit Sub

    'dimensionne le tableau
    ReDim Tbl(1 To J, 1 To 18)

    'penser à ajouter l'extension !
    newWbName = "PROG TEST Planning" & " " & newYear & ".xlsm"

    'Choix de recopier où non les informations de l'ancien document correspondant à la nouvelle année
    If MsgBox("Souhaitez-vous importer les consultations " & _
              newYear & _
              " ici présentes dans votre nouveau fichier?", _
              vbQuestion + vbYesNo, _
              "RECOPIE DE VOS INFORMATIONS PREALABLES") = vbYes Then

        choix = True

        For Each Cel In PlgDate

            If CInt(newYear) = Year(Cells(Cel.Row, COLUMN_DATE).Value) Then

                I = I + 1
                For Col = 1 To 18: Tbl(I, Col) = Cells(Cel.Row, Col): Next Col

            End If

        Next Cel

    Else

        choix = False

    End If

    'Confirmation
    If MsgBox("Confirmez vous la création d'un nouveau fichier ? " & _
              "Le fichier actuel sera simplement fermé et enregistré à son endroit habituel avant création de votre fichier " & _
              newYear & _
              ". Votre nouveau fichier sera enregistré dans le même emplacement que l'actuel sous l'appelation " & _
              Chr(34) & _
              newWbName & _
              Chr(34) & ".", _
              vbOKCancel + vbQuestion, _
              "CONFIRMATION") = vbOK Then

        'Enregistrer le fichier actuel
        ThisWorkbook.Save
        'Enregistrer-sous le nouveau fichier
        newPath = ThisWorkbook.Path & "/" & newWbName
        ThisWorkbook.SaveAs newPath
        Set TargetWb = Workbooks(newWbName)

        'Effacer tout
        With TargetWb.Sheets("Récapitulatif")

            .Activate
            .Unprotect
            .Range(Cells(2, COLUMN_TYPE), Cells(2032, COLUMN_PLURI)).ClearContents
            .Protect

        End With

        If choix = True Then                    'Si le premier choix d'importer les consultations était positif alors recopier le tableau

            With TargetWb.Sheets("Récapitulatif")

                .Unprotect
                .Range(.Cells(2, 1), .Cells(UBound(Tbl, 1) + 2, UBound(Tbl, 2))).Value = Tbl
                .Protect
                 Application.ScreenUpdating = True
                .Range("b2").Activate

            End With

        Else

            TargetWb.Sheets("Récapitulatif").Range("b2").Activate 'Retour à la dernière ligne

        End If

    End If

    Application.ScreenUpdating = True   'Rafraichissement

End Sub
Le 03/09/2018 à 19:25

2039 ? ben alors c'est un fichier futuriste ! notre ami Théophile est 21 ans en avance sur son temps !

alors, Théophile HG Wells, t'as inventé le classeur à voyager dans le temps ?

dhany

Le 04/09/2018 à 08:31

Donc, comme pseudo, Marty McFly aurait été plus adapté

Le 06/09/2018 à 14:40

Ben quoi,

il est interdit d'utiliser sa date de naissance pour simuler nos macros?

"Bonne nuit, visiteur du futur", aurait dit le doc.

Bon, merci tout d'abord Theze pour ce véritable travail que tu as fais.

Je suis un peu déçu car toute ma formulation semblait pourtant bonne, bien que peu méthodique et je ne comprends toujours pas pourquoi VBA réussi à se tromper alors que l'écriture est pourtant linéaire, bien qu'un peu rock and roll dans sa présentation. Ou alors ce que tu présente comme différence de base (0 pour l'array et 1 pour le range) contenait véritablement une erreur en plus du peu de clarté...?

Merci en tout cas pour votre aide à tous.

Rechercher des sujets similaires à "resize application transpose array"