XL 2013 Boucle de X à X

A

a_loic

XLDnaute Junior
Bonjour à tous,


Je suis à la recherche d’une aide pour une macro que j’ai commencé grâce à des recherches internet.


Il me reste une erreur que je n’arrive pas à corriger.

Concrètement j’ai en colonne A toutes les X lignes (c’est aléatoire en fonction du nombre de données) le terme « identifiant ».

Ma macro trouve ce terme et récupère en dessous les données dont j’ai besoin.
Le défaut c’est que actuellement ca cherche seulement dans les 4 lignes dessous, puis ca reprend au « identifiant » suivant etc…

Je cherche donc à enlever cette condition de 4 lignes et à mettre de identifiant à identifiant…



J’espère que je suis clair. :s


Je vous colle ci-dessous la partie du code qui fait défaut :

Code: 
        Sheets("Sheet1").Activate
        nbl = Range("D" & Rows.Count).End(xlUp).Row 'n° dernière ligne non vide
        dbl = 18 'n° ligne pour débuter la boucle
        Jour = Format(Range("O12").Value, "dd/mm/yyyy")
        
        For i = dbl To nbl
        
            If Range("A" & i) = "Identifiant" Then
            
                dbl = Range("A" & i).Row 'réinitialise le n° de ligne pour débuter le traitement à celle où se trouve l'identifiant recherché
                Range("D" & i).Offset(1, 0).Select
                l1 = ActiveCell.Row 'n° ligne pour débuter la sous-boucle (recherche de 50000088 et 30000089)
                
                    For j = l1 To l1 + 4 'recherche les n° GV sur les 4 lignes en dessous de l'identifiant

                        Range("D" & j).Select
                        
                        If Range("D" & j) = 50000088 Or ActiveCell = 30000089 Then
                            
                            Identifiant = Range("K" & i)
                            GV = Range("D" & j)
                            quantite = Range("AB" & j)


Un grand merci par avance,



Bonne journée,

Loic
 
Trier par date Trier par votes
job75

job75

XLDnaute Barbatruc
Bonjour a_loic,

En VBA les Select et autres Activate sont en général inutiles, voire nuisibles.

Et s'il y a beaucoup de données, les traiter avec un tableau VBA est beaucoup plus rapide :
Code: 
Dim F As Worksheet, tablo, i&, lig&, Identifiant, GV, quantite
Set F = Sheets("Sheet1")
tablo = F.Range("A1", F.UsedRange).Resize(, 28) 'colonnes A à AB
For i = 18 To UBound(tablo)
  If tablo(i, 1) = "Identifiant" Then lig = i 'mémorise la ligne
  If lig And (tablo(i, 4) = 50000088 Or tablo(i, 4) = 30000089) Then
    Identifiant = tablo(lig, 11)
    GV = tablo(i, 4)
    quantite = tablo(i, 28)
    '---suite du code---
  End If
Next
A+
 
Dernière édition:
Vote positif 0 Vote négatif
camarchepas

camarchepas

XLDnaute Barbatruc
Bonjour ,

Sans fichier toujours difficile de valider la solution , mais selon moi, il faut juste avoir une colonne toujours pleine lorsqu'une ligne est valide ( supposont la colonne B:)

dim LigneFin as long , LigneFin2 as long
LigneFin = Range("B" & rows.count).end(xlup).row ' Ligne de fin du fichier

l1 = ActiveCell.Row 'n° ligne pour débuter la sous-boucle (recherche de 50000088 et 30000089)
LigneFin2 = range("A" &activecell.row).end(xldown).row 'Ligne avec nouvel identifiant

For j = l1 To LigneFin2-1 'recherche les n° GV sur les 4 lignes en dessous de l'identifiant

Bonjour Job , en effet beaucoup plus efficace
 
Vote positif 0 Vote négatif
A

a_loic

XLDnaute Junior
Rebonjour :)

Merci pour vos réponses !

J'ai modifié tel que je m'imagine qu'il faut faire mais le problème c'est que maintenant mes données remontent en double...

Voici le code complet si vous y voyez l'erreur, moi jene comprends pas :(

Code: 
 Option Compare Text

Sub ImportRecap()
    Dim objOuvrir As FileDialog
    Dim objFichiers As FileDialogSelectedItems
    Dim x As Long, nblgn As Long
    Dim Wb As Workbook
    Dim LigneFin As Long, LigneFin2 As Long
 
    'Affiche la fenêtre "Ouvrir"
    With Application.FileDialog(msoFileDialogOpen)
        .InitialFileName = ""
        'Efface les filtres existants.
        .Filters.Clear
        'Définit une liste de filtres pour le champ "Type de fichiers".
        .Filters.Add "Classeurs Excel", "*.xls; *.xlsx; *.xlsm"
        'Indique le type d'affichage dans la boîte de dialogue
        .InitialView = msoFileDialogViewDetails
        .Show
    End With
 
    'Définit le ou les fichiers à ouvrir
    Set objFichiers = Application.FileDialog(msoFileDialogOpen).SelectedItems
 
    'On sort si aucun fichier n'a été sélectionné
    If objFichiers.Count = 0 Then Exit Sub
 
 
    Application.ScreenUpdating = False
 
    'Boucle sur le ou les fichiers Excel sélectionnés pour les ouvrir
    For x = 1 To objFichiers.Count
        Set Wb = Workbooks.Open(objFichiers(x))
        '
        'TRAITEMENT
        '
        Sheets("Sheet1").Activate
        nbl = Range("D" & Rows.Count).End(xlUp).Row 'n° dernière ligne non vide
        dbl = 18 'n° ligne pour débuter la boucle
        LigneFin = Range("B" & Rows.Count).End(xlUp).Row ' Ligne de fin du fichier
        l1 = ActiveCell.Row 'n° ligne pour débuter la sous-boucle (recherche de 50000088 et 30000089)
        LigneFin2 = Range("A" & ActiveCell.Row).End(xlDown).Row 'Ligne avec nouvel identifiant

 
        Jour = Format(Range("O12").Value, "dd/mm/yyyy")
        
        For i = dbl To nbl
        
            If Range("A" & i) = "Identifiant" Then
            
                dbl = Range("A" & i).Row 'réinitialise le n° de ligne pour débuter le traitement à celle où se trouve l'identifiant recherché
                Range("D" & i).Offset(1, 0).Select
                l1 = ActiveCell.Row 'n° ligne pour débuter la sous-boucle (recherche de 50000088 et 30000089)
                
                    For j = l1 To LigneFin2 - 1 'recherche les n° GV sur les 4 lignes en dessous de l'identifiant

                        Range("D" & j).Select
                        
                        If Range("D" & j) = 50000088 Or ActiveCell = 30000089 Then
                            
                            Identifiant = Range("K" & i)
                            GV = Range("D" & j)
                            quantite = Range("AB" & j)
                            
                            ThisWorkbook.Activate
                            With ThisWorkbook.Sheets("BDD_GV")
                                dl = Range("A" & Rows.Count).End(xlUp).Offset(1, 0).Row
                                Cells(dl, 1) = Jour 'si date = date du jour de l'import Récap
                                Cells(dl, 2) = Identifiant
                                Cells(dl, 3) = GV
                                Cells(dl, 4) = quantite
                            End With
                            
                            Wb.Activate
                            
                        End If
                        
                    Next j
            End If

        Next i
        '
        '
        '
        'Referme le classeur sans enregistrer les modifications.
        Wb.Close False
    Next
 
    Application.ScreenUpdating = True
 
End Sub
 
Vote positif 0 Vote négatif
A

a_loic

XLDnaute Junior
Re :)

Je te joins le document avec la macro nommé "TEST_EX.SUIVI.GV" et un exemple de recap que ma macro va chercher ("EX.RECAP.GV").


Redis moi si besoin,


Merci pour ton aide,

Bonne journée,

Loic
 

Pièces jointes

  • TEST_EX.SUIVI.GV.xlsm
    26 KB · Affichages: 27
  • EX.RECAP.GV.xls
    34.5 KB · Affichages: 31
Vote positif 0 Vote négatif
A

a_loic

XLDnaute Junior
Re :)

Pour être franc, je suis passé à côté de ta proposition.

Je viens donc de la tester et pour le coup je n'arrive pas à l'adapter.

Voilà ce que j'ai fait et j'au un débogage à tous les coup :(

Code: 
Option Compare Text

Sub ImportRecap()
  Dim objOuvrir As FileDialog
  Dim objFichiers As FileDialogSelectedItems
  Dim x As Long, nblgn As Long
  Dim Wb As Workbook
  Dim F As Worksheet, tablo, i&, lig&, Identifiant, GV, quantite
 
  'Affiche la fenêtre "Ouvrir"
  With Application.FileDialog(msoFileDialogOpen)
  .InitialFileName = ""
  'Efface les filtres existants.
  .Filters.Clear
  'Définit une liste de filtres pour le champ "Type de fichiers".
  .Filters.Add "Classeurs Excel", "*.xls; *.xlsx; *.xlsm"
  'Indique le type d'affichage dans la boîte de dialogue
  .InitialView = msoFileDialogViewDetails
  .Show
  End With
 
  'Définit le ou les fichiers à ouvrir
  Set objFichiers = Application.FileDialog(msoFileDialogOpen).SelectedItems
 
  'On sort si aucun fichier n'a été sélectionné
  If objFichiers.Count = 0 Then Exit Sub
 
 
  Application.ScreenUpdating = False
 
  'Boucle sur le ou les fichiers Excel sélectionnés pour les ouvrir
  For x = 1 To objFichiers.Count
  Set Wb = Workbooks.Open(objFichiers(x))
  '
  'TRAITEMENT
  '
  
  Set F = Sheets("Sheet1")
 tablo = F.Range("A1", F.UsedRange).Resize(, 28) 'colonnes A à AB
 Jour = Format(Range("O12").Value, "dd/mm/yyyy")
 For i = 18 To UBound(tablo)
  If tablo(i, 1) = "Identifiant" Then lig = i 'mémorise la ligne
  If lig And (tablo(i, 4) = 50000088 Or tablo(i, 4) = 30000089) Then
  Identifiant = tablo(lig, 11)
  GV = tablo(i, 4)
  quantite = tablo(i, 28)
  
  
  Identifiant = Range("K" & i)
  GV = Range("D" & j)
  quantite = Range("AB" & j)
  
  ThisWorkbook.Activate
  With ThisWorkbook.Sheets("BDD_GV")
  dl = Range("A" & Rows.Count).End(xlUp).Offset(1, 0).Row
  Cells(dl, 1) = Jour 'si date = date du jour de l'import Récap
  Cells(dl, 2) = Identifiant
  Cells(dl, 3) = GV
  Cells(dl, 4) = quantite
  End With
  
  Wb.Activate
  End If
 Next

  '
  '
  'Referme le classeur sans enregistrer les modifications.
  Wb.Close False
  Next
 
  Application.ScreenUpdating = True


Encore merci pour l'aide,

Bonne journée,

Loic
 
Vote positif 0 Vote négatif
job75

job75

XLDnaute Barbatruc
Re,

Après un sérieux nettoyage de votre code :
Code: 
Option Explicit
Option Compare Text

Sub ImportRecap()
  Dim objOuvrir As FileDialog
  Dim objFichiers As FileDialogSelectedItems
  Dim x As Long
  Dim F1 As Worksheet, dl&, Wb As Workbook
  Dim F2 As Worksheet, tablo, jour, i&, lig&
  'Affiche la fenêtre "Ouvrir"
  With Application.FileDialog(msoFileDialogOpen)
  .InitialFileName = ""
  'Efface les filtres existants.
  .Filters.Clear
  'Définit une liste de filtres pour le champ "Type de fichiers".
  .Filters.Add "Classeurs Excel", "*.xls; *.xlsx; *.xlsm"
  'Indique le type d'affichage dans la boîte de dialogue
  .InitialView = msoFileDialogViewDetails
  .Show
  End With
  'Définit le ou les fichiers à ouvrir
  Set objFichiers = Application.FileDialog(msoFileDialogOpen).SelectedItems
  'On sort si aucun fichier n'a été sélectionné
  If objFichiers.Count = 0 Then Exit Sub
  Application.ScreenUpdating = False
  Set F1 = Sheets("BDD_GV")
  dl = 7 'ligne de titres
 
  'Boucle sur le ou les fichiers Excel sélectionnés pour les ouvrir
  For x = 1 To objFichiers.Count
  Set Wb = Workbooks.Open(objFichiers(x))
  '
  'TRAITEMENT
  '
  Set F2 = Wb.Sheets("Sheet1")
  tablo = F2.Range("A1", F2.UsedRange).Resize(, 28) 'colonnes A à AB
  jour = F2.Range("O12")
  For i = 18 To UBound(tablo)
    If tablo(i, 1) Like "Identifiant*" Then lig = i 'mémorise la ligne
    If lig And (CStr(tablo(i, 4)) = "50000088" Or CStr(tablo(i, 4)) = "30000089") Then
      dl = dl + 1
      F1.Cells(dl, 1) = jour 'si date = date du jour de l'import Récap
      F1.Cells(dl, 2) = tablo(lig, 11) 'Identifiant
      F1.Cells(dl, 3) = tablo(i, 4) 'GV
      F1.Cells(dl, 4) = tablo(i, 28) 'Quantité
    End If
  Next i
  '
  '
  'Referme le classeur sans enregistrer les modifications.
  Wb.Close False
  Next x
 
  F1.Rows(dl + 1 & ":" & F1.Rows.Count).Delete 'RAZ en dessous
  Application.ScreenUpdating = True
End Sub
Remarques :

- il vaut mieux utiliser Like "Identifiant*" si l'on veut que "Identifiant collabo" soit traité

- vos 50000088 et 30000089 sont parfois des nombres, parfois des textes... d'où les CStr.

A+
 
Vote positif 0 Vote négatif
A

a_loic

XLDnaute Junior
Bonjour,

Merci pour le code et le nettoyage :)

Seul soucis c'est que désormais les données ne se cumullent pas mais se remplacent :(

De plus, la ligne "total" en bas du document de recap est prise en compte alors que seules les régions doivent l'être.

Enfin, puis-je ajouter un :
Code: 
  'Gestion si erreur d'exécution
   On Error GoTo gestionErreur

    'corps de la procédure
   '[...]
   
gestionErreur:
'affiche un message d'erreur
   MsgBox "Une erreur est survenue et l'import des données n'a pas pu être effectué."
pour empêcher que si on sélectionne un mauvais document, la macro bug?
Où dois je l'insérer car ca ne change rien quand j'essaie :)


Encore un grand merci,

Bonne journée,
Loic
 
Vote positif 0 Vote négatif
job75

job75

XLDnaute Barbatruc
Re,

Pour ce qui est de l'histoire du TOTAL remettre lig à zéro quand il est rencontré en colonne B :
Code: 
    If tablo(i, 1) Like "Identifiant*" Then lig = i 'mémorise la ligne
    If tablo(i, 2) Like "TOTAL*" Then lig = 0 'RAZ
    If lig And (CStr(tablo(i, 4)) = "50000088" Or CStr(tablo(i, 4)) = "30000089") Then
A+
 
Vote positif 0 Vote négatif

Discussions similaires

T
  • Question
XL 2016 Optimisation d'une boucle
2 3
Réponses
30
Affichages
931
thivame
T
V
  • Résolu(e)
XL 2016 Facturier : Retour à la ligne sur la facture
2
Réponses
19
Affichages
567
Vermithor
V
PORCHER
  • Question
Microsoft 365 L'indice n'appartient pas à la sélection
Réponses
8
Affichages
315
TooFatBoy
TooFatBoy
S
  • Question
Microsoft 365 VBA pour copier une une des données d'une ligne à une autre
Réponses
2
Affichages
132
crocrocro
C
D
  • Question
XL 2021 Filtre Multi Critères Listview VBA
2
Réponses
21
Affichages
270
Dranreb
Dranreb
H
  • Question
Autres mise a jour automatique feuille excel vba
Réponses
2
Affichages
292
HANN
H
halecs93
  • Résolu(e)
XL 2016 Indice n'appartient pas à la sélection : HELP !!!!
2
Réponses
21
Affichages
544
halecs93
halecs93
A
  • Résolu(e)
XL 2016 Boucle
Réponses
12
Affichages
567
Aldonanou
A
G
  • Question
Microsoft 365 Saut de ligne dans une cellule
Réponses
3
Affichages
139
GClaire
G
O
  • Question
Microsoft 365 Excel [VBA]. Erreur d’exécution 424 Objet requis sur une concaténation
Réponses
3
Affichages
153
Oneida
Oneida

Membres actuellement en ligne

17 membres et 139 invités.

Partager cette page

Tutos vidéos

Power Query : Ajouter des requêtes (Excel et Power BI)
Créez votre première fonction LAMBDA dans Excel en 3 étapes!
LAMBDA, l’arme secrète de Microsoft pour Excel !
Office Insider - Découvrez les nouveautés Excel avant tout le monde

Statistiques des forums

Discussions
312 213
Messages
2 086 302
Membres
103 174
dernier inscrit
OBUTT