VBA redimensionner array

Bonjour tout le monde,

J'essaie de travailler de plus en plus en mémoire. Dans le fichier joint, il me faut récupérer des données dans 3 colonnes, dont 2 ne se touchent pas, en fonction d'une date en colonne L.
Voici le code ci-dessous :

Sub tab_memoire()
Dim tableau(10, 3) As String
Dim date_ok As String
Dim J As Integer
Range("N1").CurrentRegion.ClearContents
date_ok = InputBox("Quelle est la date concernée ?")
J = 0
For i = 2 To Application.CountA(Range("L:L"))
If Cells(i, 12) = date_ok Then
    tableau(J, 0) = Cells(i, 7)
    tableau(J, 1) = Cells(i, 9)
    tableau(J, 2) = Cells(i, 10)
    J = J + 1
End If
Next i

Range("N1").Resize(UBound(tableau, 1), UBound(tableau, 2)) = tableau
End Sub

Tout fonctionne très bien sauf que je dois envoyer ce tableau par mail ensuite. Pour le moment je déclare 10 lignes et 3 colonnes.
Les 3 colonnes seront fixes, mais je ne sais pas combien j'aurai de lignes.

J'aimerais donc pouvoir redimensionner le tableau afin que les lignes vides soient supprimées et qu'il ne contienne que les données effectives.
Par avance un immense merci pour votre aide éclairée.

Bonjour,

Bel essai.

On ne peut redimensionner que la seconde dimension du tableau.

Donc, ton tableau se déclare comme ceci : tableau(1 To 3, 1 To J)

Je suis passé en Base 1 (1er indice de tableau = 1), mais c'est la même chose en Base 0 (1er indice de tableau = 0).

Tu l'alimente, en le préservant grâce à ReDim Preserve, et, pour le transfert dans la feuille, tu le Transposes (comme un copier/collage spécial Transposé).

Voici donc ton code modifié :

Sub TableauMemoire()
Dim tableau() As String
Dim date_ok As String
Dim J As Integer
    Range("N1").CurrentRegion.ClearContents
    date_ok = InputBox("Quelle est la date concernée ?")
    J = 1
    For i = 2 To Application.CountA(Range("L:L"))
        If Cells(i, 12) = date_ok Then
            ReDim Preserve tableau(1 To 3, 1 To J)
            tableau(1, J) = Cells(i, 7)
            tableau(2, J) = Cells(i, 9)
            tableau(3, J) = Cells(i, 10)
            J = J + 1
        End If
    Next i
    Range("N1").Resize(UBound(tableau, 2), UBound(tableau, 1)) = Application.Transpose(tableau)
End Sub

Tu vois, ici, que UBound(tableau, 2) représente le nombre de lignes et UBound(tableau, 1) le nombre de colonnes...

Bonjour,

Moi je peux te proposer ceci !

Sub tab_memoire()

Dim Lignes As Integer
For i = 2 To Range("A65535").End(xlUp).Row
     If Cells(i, "A") <> "" Then
        Lignes = Lignes + 1
    End If
Next

Dim tableau() As String

ReDim tableau(Lignes, 3)

Dim date_ok As String
Dim J As Integer
Range("N1").CurrentRegion.ClearContents
date_ok = InputBox("Quelle est la date concernée ?")
J = 0
For i = 2 To Application.CountA(Range("L:L"))
If Cells(i, 12) = date_ok Then
    tableau(J, 0) = Cells(i, 7)
    tableau(J, 1) = Cells(i, 9)
    tableau(J, 2) = Cells(i, 10)
    J = J + 1
End If
Next i

Range("N1").Resize(UBound(tableau, 1), UBound(tableau, 2)) = tableau
End Sub

Mais visiblement j'ai mal lu l'énoncer.....

Désolé

bonjour,

une proposition

Sub tab_memoire()
    Dim tableau()
    Dim date_ok As String
    Dim J As Long, dl As Long, i As Long
    Range("N1").CurrentRegion.ClearContents
    dl = Cells(Rows.Count, "L").End(xlUp).Row
    ReDim tableau(0 To dl, 0 To 2)
    date_ok = InputBox("Quelle est la date concernée ?")
    J = 0
    For i = 2 To dl
        If Cells(i, 12) = date_ok Then
            tableau(J, 0) = Cells(i, 7)
            tableau(J, 1) = Cells(i, 9)
            tableau(J, 2) = Cells(i, 10)
            J = J + 1
        End If
    Next i
    Range("N1").Resize(J, 3) = tableau
    tableau=range("N1").resize(j,3)
End Sub

Bon, puisqu'on est ici pour rigoler...

Sub tab_memoire()
Dim date_ok As String
Dim J As Long, fin As Long, Nb As Long
    Range("N1").CurrentRegion.ClearContents
    date_ok = InputBox("Quelle est la date concernée ?")
    Nb = Application.CountIf(Range("L:L"), CDate(date_ok))
    If Nb > 0 Then
        ReDim tableau(Nb, 3) As String
        fin = Application.CountA(Range("L:L"))
        For i = 2 To fin
            If Cells(i, 12) = date_ok Then
                tableau(J, 0) = Cells(i, 7)
                tableau(J, 1) = Cells(i, 9)
                tableau(J, 2) = Cells(i, 10)
                J = J + 1
            End If
        Next i
        Range("N1").Resize(UBound(tableau, 1), UBound(tableau, 2)) = tableau
    End If
End Sub

Ahah, un immense merci à vous !

C'est dingue comme on peut être si près et si loin en même temps d'une solution qui fonctionne !

Je viens de tout tester.

@Moul, ah, je viens de voir ton edit. J'étais en train de te dire que ça ne répondait pas vraiment à la demande

@Pijaku et @h2so4, c'est comme d'habitude : parfait !
Et j'y vois beaucoup plus clair maintenant ! Je savais en théorie qu'on ne pouvait pas redimensionner la 2ème dimension mais, en pratique, je ne savais pas quelle solution mettre en oeuvre pour contourner ce problème !

en pratique, je ne savais pas quelle solution mettre en oeuvre pour contourner ce problème !

En fait, ce n'est pas un problème.

Si tu commences à "traiter en mémoire", il te faut connaître toutes ces possibilités. Et bien d'autres encore.

Dernière chose, ma solution utilisant transpose est limitée à 65536...

Maintenant que la base est un peu mieux acquise, je pense que je serai plus à même d'intégrer les tutos silkyroad ou autres.

Par contre, j'essaie d'intégrer mon tableau dans le body d'un mail et il me met incompatibilité de type :(

Strbody = "<html><body>Bonjour," & "<br><br>" _
    & "blablabla." & "<br>" & tableau & "Vous en souhaitant bonne réception," & "<br>"

C'est (beaucoup) plus complexe que cela.

Si tu ne l'as pas, télécharge le add-in des fonctions de ce site...

https://www.excel-pratique.com/fr/fonctions-complementaires/tableau-html

Aïe mince, je n'imaginais pas les choses comme ça :(

Pour le pack de fonctions du site, j'aime autant m'en passer et faire avec les outils auxquels à priori tout le monde a accès. C'est plus universel. Là c'est pour aider quelqu'un qui bosse dans une institution publique. Et c'est sûr à 99% qu'ils ne l'installeront pas. Ils ne veulent déjà pas déployer PowerQuery ...

Bon, il va falloir générer le mail directement dans Excel alors j'imagine.

Voici un exemple (envoi via Outlook) vite fait :

Sub tab_memoire()
Dim date_ok As String, strHTML As String
Dim j As Long, fin As Long, Nb As Long
    Range("N1").CurrentRegion.ClearContents
    date_ok = InputBox("Quelle est la date concernée ?")
    Nb = Application.CountIf(Range("L:L"), CDate(date_ok))
    If Nb > 0 Then
        ReDim tableau(Nb - 1, 2) As String
        fin = Application.CountA(Range("L:L"))
        For i = 2 To fin
            If Cells(i, 12) = date_ok Then
                tableau(j, 0) = Cells(i, 7)
                tableau(j, 1) = Cells(i, 9)
                tableau(j, 2) = Cells(i, 10)
                j = j + 1
            End If
        Next i
        Range("N1").Resize(UBound(tableau, 1), UBound(tableau, 2)) = tableau
    End If
    CreateHTMLMail tableau
End Sub

Sub CreateHTMLMail(tb() As String)
Dim OutApp As Object, OutMail As Object, Ind As Integer
    Set OutApp = CreateObject("Outlook.Application")
    Set OutMail = OutApp.CreateItem(0)
    On Error Resume Next
    With OutMail
        .To = "adresse.destinataire@mail.com"
        .CC = "adresse.copie@mail.com"
        .BCC = "adresse.copiecachée@mail.com"
        .Subject = "sujet du mail"
        .HTMLBody = ExcelToHtml(tb)
        .Display
    End With
    On Error GoTo 0
    Set OutMail = Nothing
    Set OutApp = Nothing

End Sub

Function ExcelToHtml(tb() As String) As String
Dim i As Long, j As Long, strTemp As String
    strTemp = "<TABLE Border=1>"
    For i = LBound(tb, 1) To UBound(tb, 1)
        strTemp = strTemp & "<TR>"
        For j = LBound(tb, 2) To UBound(tb, 2)
            strTemp = strTemp & "<TD>" & tb(i, j) & "</TD>"
        Next j
        strTemp = strTemp & "</TR>"
    Next i
    ExcelToHtml = strTemp & "</TABLE>"
End Function

Bon, puisqu'on est ici pour rigoler :

ReDim tableau(Nb - 1, 2) As String

Ça enlève une ligne au tableau et il manque donc une donnée ;) Sans le -1 c'est nickel.

Sinon, pour le reste, que dire...

capture

C'est juste parfait ! Incroyable ! Amazing !

Encore une fois merci énormément !!

Bon, puisqu'on rigole bien finalement ici...

Tu peux "personnaliser" ton tableau HTML un peu plus.

Par exemple :

Sub essssssssai()
    Dim a(2, 2) As String
    a(0, 0) = "0"
    a(0, 1) = "1"
    a(0, 2) = "2"
    a(1, 0) = "10"
    a(1, 1) = "11"
    a(1, 2) = "12"
    a(2, 0) = "20"
    a(2, 1) = "21"
    a(2, 2) = "22"
    CreateHTMLMail a, 6, 12, 15, 80
End Sub
Sub CreateHTMLMail(tb() As String, Optional Bordure As Integer = 1, Optional CellSpac As Integer = 1, Optional CellPad As Integer = 1, Optional W As Integer = 50)
Dim OutApp As Object, OutMail As Object, Ind As Integer
    Set OutApp = CreateObject("Outlook.Application")
    Set OutMail = OutApp.CreateItem(0)
    On Error Resume Next
    With OutMail
        .To = "adresse.destinataire@mail.com"
        .cc = "adresse.copie@mail.com"
        .BCC = "adresse.copiecachée@mail.com"
        .Subject = "sujet du mail"
        .HTMLBody = ExcelToHtml(tb, Bordure, CellSpac, CellPad, W)
        .Display
    End With
    On Error GoTo 0
    Set OutMail = Nothing
    Set OutApp = Nothing
End Sub
Function ExcelToHtml(tb() As String, Optional Bordure As Integer, Optional CellSpac As Integer, Optional CellPad As Integer, Optional W As Integer) As String
Dim i As Long, j As Long, strTemp As String
    strTemp = "<TABLE border=" & Bordure & " cellspacing=" & CellSpac & " cellpadding=" & CellPad & " width=" & W & "%>"
    For i = LBound(tb, 1) To UBound(tb, 1)
        strTemp = strTemp & "<TR>"
        For j = LBound(tb, 2) To UBound(tb, 2)
            strTemp = strTemp & "<TD>" & tb(i, j) & "</TD>"
        Next j
        strTemp = strTemp & "</TR>"
    Next i
    ExcelToHtml = strTemp & "</TABLE>"
End Function
Rechercher des sujets similaires à "vba redimensionner array"