Modification macro Visual Basic

Fermé
nicoloupiot Messages postés 1 Date d'inscription lundi 2 décembre 2019 Statut Membre Dernière intervention 2 décembre 2019 - 2 déc. 2019 à 17:47
ALS35 Messages postés 1033 Date d'inscription jeudi 18 juillet 2019 Statut Membre Dernière intervention 9 janvier 2024 - 3 déc. 2019 à 10:29
Bonjour à tous,
Je dois mettre à jour, de manière récurrente, un document contenant une macro, qui permet d'identifier des données dans une feuille source, et les coller dans une feuille de destination, et cela selon quelques critères, sélectionnés au préalable par l'utilisateur (région, département, etc.)
Or, les données collées dans la feuille de destination, sont souvent (mais pas tout le temps) incomplètes.
Je suppose que la macro ne va pas jusqu'à la fin de la feuille source pour rapatrier les données. Pourtant, la feuille source contient environ 40000 lignes et la macro va chercher jusqu'à la ligne 100000 pour identifier la dernière ligne :

derniere_ligne = source.Range(" A100000 ").End(xlUp).Row


Ci-dessous le code en question :

Sub MiseAJour()


'Range("B2") = Timer
'nommer les feuilles
Dim source, cible As Worksheet
Set source = Sheets("Data")
Set cible = Sheets("IMPAYES")
On Error Resume Next

'Repérer la dernière ligne des sources de données. Se placer tout en bas de la feuille excel et remonter autant que possible, la première ligne rencontrée = la dernière ligne de la source des données
Dim derniere_ligne_source, premiere_ligne_source, premiere_ligne_cible As Integer
derniere_ligne = source.Range(" A100000 ").End(xlUp).Row
premiere_ligne_source = 1

'Repérer la première ligne dans l'onglet cible qui est 14
premiere_ligne_cible = 14

'Repérer la zone dans impayés à effacer avant de mettre à jour les informations et effacer
cible.Range(" A14 :Q100000 ").Clear

'Parcourir chaque ligne de la source, des que les conditions sont remplies, copier les information de l'autre cote.
'Parcourir toutes les lignes de la source
For l = 2 To derniere_ligne
If compare_critere_et_ligne_data(l) = True Then 'fonction compare_critere_et _ligne_data vérifie que les conditions sont remplies
Call copy_i_to_j(l, premiere_ligne_cible) 'fonction copie
premiere_ligne_cible = premiere_ligne_cible + 1
End If
Next

End Sub

'comparaison des critères : si les critères sont remplis, la fonction renvoie "oui", sinon elle renvoie "non"
Function compare_critere_et_ligne_data(ByVal ligne_data As Integer)

Dim source, cible As Worksheet
Set source = Sheets("Data")
Set cible = Sheets("IMPAYES")

region_cible = cible.Range(" B5 ")
grand_centre_cible = cible.Range(" B7 ")
centre_cible = cible.Range(" B9 ")
tranche_impaye_cible = cible.Range(" B11 ")

region_source = source.Range("A1").Offset(ligne_data - 1, 0)
grand_centre_source = source.Range("A1").Offset(ligne_data - 1, 1)
centre_source = source.Range("A1").Offset(ligne_data - 1, 2)
tranche_impaye_source = source.Range("A1").Offset(ligne_data - 1, 13)


'Partir du principe que les conditions sont remplies
compare_critere_et_ligne_data = True

'si un des critère source est vide alors ne pas le considérer comme un critère d'où le premier test region_source<> " "
If region_cible <> region_source Then
compare_critere_et_ligne_data = False
End If

If Not compare_critere_et_ligne_data = True And grand_centre_cible <> grand_centre_source And grand_centre_cible <> Empty Then
compare_critere_et_ligne_data = False
End If

If compare_critere_et_ligne_data = True And centre_cible <> centre_source And centre_cible <> Empty Then
compare_critere_et_ligne_data = False
End If

If compare_critere_et_ligne_data = True And tranche_impaye_cible <> tranche_impaye_source And tranche_impaye_cible <> Empty Then
compare_critere_et_ligne_data = False
End If

End Function

'fonction pour copier les données de la ligne i de l'onglet source (data) vers la ligne j de l'onglet cible (impayé)
Sub copy_i_to_j(ByVal i As Integer, ByVal j As Integer)

Application.ScreenUpdating = False 'ne pas visualiser les mouvements d'écran

Dim source, cible As Worksheet
Set source = Sheets("Data")
Set cible = Sheets("IMPAYES")

cible.Range("A" & j) = source.Range("B" & i)
cible.Range("B" & j) = source.Range("G" & i)
cible.Range("D" & j) = source.Range("C" & i)
cible.Range("E" & j) = source.Range("H" & i)
cible.Range("F" & j) = source.Range("I" & i)
cible.Range("G" & j) = source.Range("J" & i)
cible.Range("H" & j) = source.Range("K" & i)
cible.Range("I" & j) = source.Range("T" & i)
cible.Range("J" & j) = source.Range("U" & i)
cible.Range("K" & j) = source.Range("N" & i)
cible.Range("L" & j) = source.Range("O" & i)
cible.Range("M" & j) = source.Range("P" & i)
cible.Range("N" & j) = source.Range("E" & i)
cible.Range("O" & j) = source.Range("Q" & i)
cible.Range("P" & j) = source.Range("R" & i)
cible.Range("Q" & j) = source.Range("S" & i)

'mettre les date de pièce et date d'échéance au format date
cible.Range("O14").Select
Range(Selection, Selection.End(xlDown)).Select
Selection.NumberFormat = "m/d/yyyy"
cible.Range("P14").Select
Range(Selection, Selection.End(xlDown)).Select
Selection.NumberFormat = "m/d/yyyy"

'mettre le montant pièce au format monétaire
cible.Range("L14").Select
Range(Selection, Selection.End(xlDown)).Select
Selection.NumberFormat = "#,##0.00 _€"

'Se positionner en cellule A13
cible.Range("A13").Select

Application.ScreenUpdating = True 'fin de ne pas visualiser les mouvements d'écran

End Sub

Function restant(t_départ As Single, taux As Single, Optional lib_temps As String = "temps restant estimé") As String
'renvoie un texte indiquant le temps restant
Dim pct As Single, mn As Single, t_restant As Single
restant = ""
pct = minimaxi(taux) 'utile pour ne pas changer la variable taux et met le pourcentage entre 0 et 100%
If t_départ <> 0 And pct <> 0 Then
'texte pour le temps restant
restant = lib_temps + " "
'calcul du temps restant en fonction du nombre de boucles
t_restant = (Timer - t_départ) / pct * (1 - pct)
mn = Int(t_restant / 60) 'calcul du nombre de minutes
If mn > 0 Then
t_restant = t_restant - mn * 60 'secondes
restant = restant + FormatNumber(mn, 0) + " mn "
End If
restant = restant + FormatNumber(t_restant, 1) + " s"
End If
End Function
Function minimaxi(x As Single, Optional maxi As Single = 1, Optional mini As Single = 0)
'borne x entre les valeurs mini et maxi utilisé ici pour rester entre 0 et 1
minimaxi = IIf(x > mini, IIf(x > maxi, maxi, x), mini)
End Function

Comment identifier d'où vient le problème ?

Mon niveau en Visual Basic ne me permet pas d'identifier la source du problème...

Merci infiniment pour votre aide, à votre disposition pour échanger

Cordialement,

Nicolas
A voir également:

2 réponses

f894009 Messages postés 17185 Date d'inscription dimanche 25 novembre 2007 Statut Membre Dernière intervention 15 avril 2024 1 701
2 déc. 2019 à 18:09
Bonjour,
Code pour derniere cellule non vide:
derniere_ligne = Range("A" & Rows.Count).End(xlUp).Row


Mais vu que feuille source 40000 lignes et votre code derniere ligne va a 100000, pense pas que le probleme soit la!!!
0
ALS35 Messages postés 1033 Date d'inscription jeudi 18 juillet 2019 Statut Membre Dernière intervention 9 janvier 2024 139
Modifié le 3 déc. 2019 à 10:32
Bonjour,

Quand tu définis des variables adressant des lignes en Integer tu es limité à 32767. Si tu veux aller à 40000 définis-les en Long. Tu as aussi des erreurs et des oublis de déclarations.
Essaie avec ça
Dim derniere_ligne_source As Long, premiere_ligne_source As Long, premiere_ligne_cible As Long, l As Long
derniere_ligne_source = Range("A" & Rows.Count).End(xlUp).Row

et ça
Sub copy_i_to_j(ByVal i As Long, ByVal j As Long)


Cordialement
0