Code trop lent lors de l'exécution
Bonsoir
Merci pour le temps que vous accordez à mes sujets.
J'ai ce code qui prends les données dans un tableau structuré selon la valeur de B4 de la feuille destinataire.
mais c'est trop lent.
Quelqu'un peut-il le simplifier en rajoutant aussi que selon les conditions de O3 et P3, les données peuvent être vides, là aucune extraction ?
Merci d'avance.
Sub ExtraireDonnéesEtudiant()
Dim Sh As Worksheet, ShO As Worksheet, Sht As Worksheet
Dim rCel As Range, cValue As Range, Wb As Workbook, lRow As Long
Dim Plage As ListObject, Trouv As Variant, c As Range
Dim Msg As String, StMsg As String, j As Integer, rJ As Integer
Application.ScreenUpdating = False
Set Wb = ThisWorkbook
Set Sh = Wb.Sheets("Records")
Set ShO = Wb.Sheets("BD")
Set Sht = Wb.Sheets("Créances")
Set Plage = Sh.ListObjects("Données")
' Boucler sur les clients
With Sht
If Not IsEmpty(.Range("B4")) Then
If (Not IsEmpty(.Range("O3")) And .Range("O3").Value >= 50 And .Range("P3") <> "NO") Then
For Each c In Plage.ListColumns(2).DataBodyRange.Cells
If c.Value = .Range("B4").Value Then
If c.Offset(, 11).Value <> Empty Then
.Range("B4") = c.Value
rJ = 35
lRow = .Cells(.Rows.Count, 2).End(xlUp).Row + 1
.Range("C" & lRow) = VBA.Left(c.Offset(, 1).Value, rJ) & "..." 'N° Libellé
.Range("B" & lRow) = c.Offset(, 2).Value 'N° fact
.Range("G" & lRow) = c.Offset(, 4).Value 'MT HT
.Range("H" & lRow) = c.Offset(, 5).Value 'MT TTC
.Range("I" & lRow) = c.Offset(, 6).Value 'NAP
.Range("D" & lRow) = c.Offset(, 8).Value 'Date Fact
.Range("E" & lRow) = c.Offset(, 9).Value 'Date Dépot
.Range("F" & lRow) = c.Offset(, 10).Value 'Date Echeance
.Range("J" & lRow) = c.Offset(, 15).Value 'Solde facture
End If
End If
Next c
Else
MsgBox "L'apprenant " & .Range("B4").Value & " est à jour.", vbOKOnly + vbCritical, "Erreur"
Exit Sub
End If
Else
MsgBox "Veuillez d'abord chosir un client", vbOKOnly + vbCritical, "Erreur"
.Range("B4").Activate
Exit Sub
End If
End With
Application.ScreenUpdating = True
Set Sh = Nothing
Set ShO = Nothing
Set Sht = Nothing
End SubBonsoir
Code à tester
Sub ExtraireDonnéesEtudiant()
Dim Sh As Worksheet, ShO As Worksheet, Sht As Worksheet
Dim Wb As Workbook, lRow As Long
Dim Plage As ListObject
Dim Msg As String
Dim rJ As Integer
Dim data As Variant
Dim i As Long
Application.ScreenUpdating = False
Set Wb = ThisWorkbook
Set Sh = Wb.Sheets("Records")
Set ShO = Wb.Sheets("BD")
Set Sht = Wb.Sheets("Créances")
Set Plage = Sh.ListObjects("Données")
' Charger les données dans un tableau
data = Plage.DataBodyRange.Value
With Sht
If Not IsEmpty(.Range("B4")) Then
If (Not IsEmpty(.Range("O3")) And .Range("O3").Value >= 50 And .Range("P3") <> "NO") Then
For i = 1 To UBound(data, 1)
If data(i, 2) = .Range("B4").Value Then
If data(i, 12) <> Empty Then
.Range("B4") = data(i, 2)
rJ = 35
lRow = .Cells(.Rows.Count, 2).End(xlUp).Row + 1
.Range("C" & lRow) = VBA.Left(data(i, 2), rJ) & "..." 'N° Libellé
.Range("B" & lRow) = data(i, 3) 'N° fact
.Range("G" & lRow) = data(i, 5) 'MT HT
.Range("H" & lRow) = data(i, 6) 'MT TTC
.Range("I" & lRow) = data(i, 7) 'NAP
.Range("D" & lRow) = data(i, 9) 'Date Fact
.Range("E" & lRow) = data(i, 10) 'Date Dépot
.Range("F" & lRow) = data(i, 11) 'Date Echeance
.Range("J" & lRow) = data(i, 16) 'Solde facture
End If
End If
Next i
Else
MsgBox "L'apprenant " & .Range("B4").Value & " est à jour.", vbOKOnly + vbCritical, "Erreur"
Exit Sub
End If
Else
MsgBox "Veuillez d'abord choisir un client", vbOKOnly + vbCritical, "Erreur"
.Range("B4").Activate
Exit Sub
End If
End With
Application.ScreenUpdating = True
Set Sh = Nothing
Set ShO = Nothing
Set Sht = Nothing
End SubCordialement
Hello,
Une proposition également
Sub ExtraireDonnéesEtudiant()
Dim wsC As Worksheet, data As Variant
Dim i As Long, r As Long
Dim nom As String, score, statut
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Application.EnableEvents = False
Set wsC = Sheets("Créances")
nom = wsC.Range("B4").Value
score = wsC.Range("O3").Value
statut = wsC.Range("P3").Value
If nom = "" Then
MsgBox "Veuillez choisir un client.", vbExclamation: GoTo Fin
End If
If IsEmpty(score) Or score < 50 Or statut = "NO" Then
MsgBox "L'apprenant " & nom & " est à jour.", vbInformation: GoTo Fin
End If
data = Sheets("Records").ListObjects("Données").DataBodyRange.Value
For i = 1 To UBound(data)
If data(i, 2) = nom And data(i, 13) <> "" Then
r = wsC.Cells(wsC.Rows.Count, 2).End(xlUp).Row + 1
With wsC
.Cells(r, 2).Resize(1, 9).Value = Array( _
data(i, 3), _
Left(data(i, 4), 35) & "...", _
data(i, 9), data(i, 10), data(i, 11), _
data(i, 5), data(i, 6), data(i, 7), data(i, 16))
End With
End If
Next i
Fin:
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
Application.EnableEvents = True
End Sub@+
Merci @BAROUTE78 et Joco7915.
Déjà Joco, ta fonction rame plus que la mienne.
Celle de Baroute est plutôt rapide, mais ne met pas les valeurs dans les cases appropriées, ignore même certaines valeurs.
Je n'arrive pas à bien interpréter cette partie pour le faire moi-même.
With wsC
.Cells(r, 2).Resize(1, 9).Value = Array( _
data(i, 3), _
Left(data(i, 4), 35) & "...", _
data(i, 9), data(i, 10), data(i, 11), _
data(i, 5), data(i, 6), data(i, 7), data(i, 16))
End WithMais ton code est super balèze.
Merci à tous, j'ai compris le fonctionnement de la méthode de BAROUTE78.
Il faut compter les offset du tableau à partir de la colonne 1 et non 2 comme dans mon code.
Ton code est mieux adapté, merci infiniment.
Merci aussi à JOCO.
bonjour le fil,
une autre macro, plus rapide (on ne colle qu'une fois vos données) et si la macro se trouve dans un module normal, il ne faut plus spécifier la feuille du Listobject
Sub ExtraireDonnéesEtudiant()
Dim Data, aOut, i, ptr As Integer, Nom, Score, Statut
With Sheets("Créances")
Nom = .Range("B4").Value
Score = .Range("O3").Value
Statut = .Range("P3").Value
If Nom = "" Then
MsgBox "Veuillez choisir un client.", vbExclamation
Else
If IsEmpty(Score) Or Score < 50 Or Statut = "NO" Then
MsgBox "L'apprenant " & Nom & " est à jour.", vbInformation
Else
Data = Range("Données").ListObject.DataBodyRange.Value2 'matrice avec les données du LO
ReDim aOut(1 To UBound(Data), 1 To 9) 'matrice vide pour les choses à transférer, nombre de lignes = nombre de data et 9 colonnes
For i = 1 To UBound(Data)
If Data(i, 2) = Nom And Data(i, 13) <> "" Then
ptr = ptr + 1 'nouvelle ligne dans aOut
aOut(ptr, 1) = Data(i, 3)
aOut(ptr, 2) = Left(Data(i, 4), 35) & "..."
aOut(ptr, 3) = Data(i, 9)
aOut(ptr, 4) = Data(i, 10)
aOut(ptr, 5) = Data(i, 11)
aOut(ptr, 6) = Data(i, 5)
aOut(ptr, 7) = Data(i, 6)
aOut(ptr, 8) = Data(i, 7)
aOut(ptr, 9) = Data(i, 16)
End If
Next i
If ptr > 0 Then .Cells(Rows.Count, 2).End(xlUp).Offset(1).Resize(ptr, 9) = aOut ' s'il y a des lignes dans aOut, coller dans Créances
End If
End If
End With
End SubBonjour BsAlv, merci pour ton code.
S'il te plait, (valable pour tous les autre) peux-tu m'ajouter une ligne de total sous ce code dans les 04 dernières colonnes et colonne1 = Total général ?
Merci d'avance
re,
vous collez le résultat dans un autre listobject (tableau structuré) et c'est de ce listobject que vous voulez un total de la première et des 4 dernières listcolumns ?
on modifie le colle en ceci, les totaux,on les avait déjà défini, donc ce n'est qu'une mise à jour.
If ptr > 0 Then
With Range("Autre Tableau").ListObject 'l'autre tableau structuré
.ShowTotals = False
.ListRows.Add.Range.Resize(ptr, 9) = aOut ' s'il y a des lignes dans aOut, coller dans Créances
.ShowTotals = True
End With
End IfBonjour,
J'arrive après la bataille mais on ne sait jamais...
As-tu un fichier exemple à nous déposer ?
Bonsoir à tous.
BsAlv, non, juste à la suite de ton code, on insère le total des colonnes G à I de la feuille créance, juste après extraction des données
c'est difficile sans fichier, mais un essai "aveugle"
Sub ExtraireDonnéesEtudiant()
Dim Data, aOut, i, ptr As Integer, Nom, Score, Statut
With Sheets("Créances")
Nom = .Range("B4").Value
Score = .Range("O3").Value
Statut = .Range("P3").Value
If Nom = "" Then
MsgBox "Veuillez choisir un client.", vbExclamation
Else
If IsEmpty(Score) Or Score < 50 Or Statut = "NO" Then
MsgBox "L'apprenant " & Nom & " est à jour.", vbInformation
Else
Data = Range("Données").ListObject.DataBodyRange.Value2 'matrice avec les données du LO
ReDim aOut(1 To UBound(Data), 1 To 9) 'matrice vide pour les choses à transférer, nombre de lignes = nombre de data et 9 colonnes
For i = 1 To UBound(Data)
If Data(i, 2) = Nom And Data(i, 13) <> "" Then
ptr = ptr + 1 'nouvelle ligne dans aOut
aOut(ptr, 1) = Data(i, 3)
aOut(ptr, 2) = Left(Data(i, 4), 35) & "..."
aOut(ptr, 3) = Data(i, 9)
aOut(ptr, 4) = Data(i, 10)
aOut(ptr, 5) = Data(i, 11)
aOut(ptr, 6) = Data(i, 5)
aOut(ptr, 7) = Data(i, 6)
aOut(ptr, 8) = Data(i, 7)
aOut(ptr, 9) = Data(i, 16)
End If
Next i
If ptr > 0 Then
With .Cells(Rows.Count, 2).End(xlUp).Offset(1)
.Resize(ptr, 9) = aOut ' s'il y a des lignes dans aOut, coller dans Créances
.Offset(ptr).Resize(1, 9).FormulaR1C1 = "=sum(R[-" & ptr & "]C:R[-1]C)" 'pour chaque colonne, la somme des lignes ajoutées
.Offset(ptr, 1).Resize(1, 6).ClearContents 'supprimer ces subtotaux pour les colonnes (relatives) 2-7
End With
End If
End If
End If
End With
End Sub