Modification macro Visual Basic
nicoloupiot
Messages postés
1
Statut
Membre
-
ALS35 Messages postés 1041 Statut Membre -
ALS35 Messages postés 1041 Statut Membre -
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
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:
- Modification macro Visual Basic
- Visual basic - Télécharger - Langages
- Suivi de modification word - Guide
- Visual basic editor - Télécharger - Langages
- Telecharger macro convertir chiffre en lettre excel - Télécharger - Tableur
- Visual petanque - Télécharger - Sport
2 réponses
Bonjour,
Code pour derniere cellule non vide:
Mais vu que feuille source 40000 lignes et votre code derniere ligne va a 100000, pense pas que le probleme soit la!!!
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!!!
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
et ça
Cordialement
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