VBA redimensionner array
- Messages
- 3'581
- Excel
- 2013, 2019, 365
- Inscrit
- 11/04/2020
- Emploi
- Formateur bureautique, dvpt fichiers
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
- Messages
- 3'581
- Excel
- 2013, 2019, 365
- Inscrit
- 11/04/2020
- Emploi
- Formateur bureautique, dvpt fichiers
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...
- Messages
- 3'581
- Excel
- 2013, 2019, 365
- Inscrit
- 11/04/2020
- Emploi
- Formateur bureautique, dvpt fichiers
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
- Messages
- 3'581
- Excel
- 2013, 2019, 365
- Inscrit
- 11/04/2020
- Emploi
- Formateur bureautique, dvpt fichiers
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
- Messages
- 3'581
- Excel
- 2013, 2019, 365
- Inscrit
- 11/04/2020
- Emploi
- Formateur bureautique, dvpt fichiers
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