Récupération de données VBA

Le 01/08/2022 à 15:50

Bien le bonjour tout le monde,

Je débute en vba et je souhaite coder un programme qui me permet de retirer que certaines données des fichiers:

PB: il s'arrête au premier fichier et ne fait pas du tout de boucle...

merci d'avance...

Sub CombinerPlusieursFeuilleDansClasseurExistant()
   On Error GoTo eh
'Déclaration des variables pour contenir les objets requis
   Dim wbDestination As Workbook
   Dim wbSource As Workbook
   Dim wsDestination As Worksheet
   Dim wb As Workbook
   Dim sh As Worksheet
   Dim strSheetName As String
   Dim strDestName As String
   Dim iRws As Integer
   Dim iCols As Integer
   Dim totRws As Integer
   Dim rngEnd As String
   Dim rngSource As Range
'Défini le classeur actif en tant que classeur de destination
   Set wbDestination = ActiveWorkbook
'Récupère le nom du classeur actif
   strDestName = wbDestination.Name
'Désactive la mise à jour de l'écran pour accélérer l'exécution
   Application.ScreenUpdating = False
'Création d'une nouvelle feuille de destination dans le classeur actif
   Application.DisplayAlerts = False
'Ignore les erreurs dans le cas où la feuille n'existerait pas
   On Error Resume Next
   ActiveWorkbook.Sheets("Consolidation").Delete
'Réinitialise la gestion des erreurs initiale
   On Error GoTo eh
   Application.DisplayAlerts = True
'Ajoutes une nouvelle feuille au classeur
   With ActiveWorkbook
      Set wsDestination = .Sheets.Add(After:=.Sheets(.Sheets.Count))
      wsDestination.Name = "Consolidation"
   End With
'Boucle sur chaque fichier ouvert pour récupérer les données
   For Each wb In Application.Workbooks
      If wb.Name <> strDestName And wb.Name <> "PERSONAL.XLSB" Then
         Set wbSource = wb
         For Each sh In wbSource.Worksheets

'Suppression des images
                Dim Img As Object
                For Each Img In ActiveSheet.Pictures
                    Img.Delete
                Next Img

'Initialisation
                Range("A1:A100").UnMerge
                Columns(1).SpecialCells(xlCellTypeBlanks).EntireRow.Delete

'Filtre
                With ActiveSheet.UsedRange
                For j = .Columns.Count To 1 Step -1
                Set C = .Columns(j)
                If WorksheetFunction.CountIf(C, "code") + WorksheetFunction.CountIf(C, "qté") = 0 Then .Columns(j).Delete
                    Next
                End With

'Supprime les lignes des cellules vides de la colonne Qté
                For i = Range("A" & Rows.Count).End(xlUp).Row To 1 Step -1
                    If Cells(i, 2) = "" Then
                        Cells(i, 2).EntireRow.Delete
                    End If
                Next i

'Supprime les doublons au sein d'une même page
                For i = Range("A1").End(xlDown).Row To 2 Step -1
                       If Range("A" & i).Value > "" Then
                        If Application.WorksheetFunction.CountIf(Range("A1:A" & Range("A65535").End(xlUp).Row), _
                           Range("A" & i).Value) > 1 Then Range("A" & i).EntireRow.Delete: i = i + 1
                    End If
                Next i

'Récupère le nombre de rangée dans le feuille
               sh.Activate
               ActiveSheet.Cells.SpecialCells(xlCellTypeLastCell).Activate
               iRws = ActiveCell.Row
               iCols = ActiveCell.Column
               rngEnd = sh.Cells(iRws, iCols).Address
               Set rngSource = sh.Range("A1:" & rngEnd)

'Trouves la dernière rangée dans la feuille de destination
               wbDestination.Activate
               Set wsDestination = ActiveSheet
               wsDestination.Cells.SpecialCells(xlCellTypeLastCell).Select
               totRws = ActiveCell.Row

'Vérifie qu'il y a assez de rangée libre dans la feuille de destination pour coller les données
               If totRws + rngSource.Rows.Count > wsDestination.Rows.Count Then
                  MsgBox "There are not enough rows to place the data in the Consolidation worksheet."
                  GoTo eh
               End If
'Ajoute une rangée pour coller les données dans la prochaine rangée vide
               If totRws <> 1 Then totRws = totRws + 1
               rngSource.Copy Destination:=wsDestination.Range("A" & totRws)
            Next sh
        End If

    Next wb

'Fermeture des classeurs ouverts à l'exception du classeur actif et du classeur personnel
   For Each wb In Application.Workbooks
      If wb.Name <> strDestName And wb.Name <> "PERSONAL.XLSB" Then
         wb.Close False
      End If
   Next wb

'Nettoyage des objets pour libérer la mémoire
   Set wbDestination = Nothing
   Set wbSource = Nothing
   Set wsDestination = Nothing
   Set rngSource = Nothing
   Set wb = Nothing
'Active la mise à jour de l'écran
   Application.ScreenUpdating = True
Exit Sub
eh:
MsgBox Err.Description
End Sub
Le 01/08/2022 à 16:19

bonjour,

1) la boucle se fait sur les classeurs ouverts et uniquement les classeurs ouverts (et à mon avis correctement)

2) il manque le nom de parent pour certains de tes objets (range, cells et columns), sinon cela fait référence au parent actif (feuille, classeur, ...)

voici une proposition de correction (non testée)

Sub CombinerPlusieursFeuilleDansClasseurExistant()
   On Error GoTo eh
'Déclaration des variables pour contenir les objets requis
   Dim wbDestination As Workbook
   Dim wbSource As Workbook
   Dim wsDestination As Worksheet
   Dim wb As Workbook
   Dim sh As Worksheet
   Dim strSheetName As String
   Dim strDestName As String
   Dim iRws As Integer
   Dim iCols As Integer
   Dim totRws As Integer
   Dim rngEnd As String
   Dim rngSource As Range
'Défini le classeur actif en tant que classeur de destination
   Set wbDestination = ActiveWorkbook
'Récupère le nom du classeur actif
   strDestName = wbDestination.Name
'Désactive la mise à jour de l'écran pour accélérer l'exécution
   Application.ScreenUpdating = False
'Création d'une nouvelle feuille de destination dans le classeur actif
   Application.DisplayAlerts = False
'Ignore les erreurs dans le cas où la feuille n'existerait pas
   On Error Resume Next
   ActiveWorkbook.Sheets("Consolidation").Delete
'Réinitialise la gestion des erreurs initiale
   On Error GoTo eh
   Application.DisplayAlerts = True
'Ajoutes une nouvelle feuille au classeur
   With ActiveWorkbook
      Set wsDestination = .Sheets.Add(After:=.Sheets(.Sheets.Count))
      wsDestination.Name = "Consolidation"
   End With
'Boucle sur chaque fichier ouvert pour récupérer les données
   For Each wb In Application.Workbooks
      If wb.Name <> strDestName And wb.Name <> "PERSONAL.XLSB" Then
         Set wbSource = wb
         For Each sh In wbSource.Worksheets

'Suppression des images
                Dim Img As Object
                For Each Img In sh.Pictures
                    Img.Delete
                Next Img

'Initialisation
                sh.Range("A1:A100").UnMerge
                sh.Columns(1).SpecialCells(xlCellTypeBlanks).EntireRow.Delete

'Filtre
                With sh.UsedRange
                For j = .Columns.Count To 1 Step -1
                Set C = .Columns(j)
                If WorksheetFunction.CountIf(C, "code") + WorksheetFunction.CountIf(C, "qté") = 0 Then .Columns(j).Delete
                    Next
                End With

'Supprime les lignes des cellules vides de la colonne Qté
                For i = sh.Range("A" & Rows.Count).End(xlUp).Row To 1 Step -1
                    If sh.Cells(i, 2) = "" Then
                        sh.Cells(i, 2).EntireRow.Delete
                    End If
                Next i

'Supprime les doublons au sein d'une même page
                For i = sh.Range("A1").End(xlDown).Row To 2 Step -1
                       If sh.Range("A" & i).Value > "" Then
                        If Application.WorksheetFunction.CountIf(sh.Range("A1:A" & Range("A65535").End(xlUp).Row), _
                           sh.Range("A" & i).Value) > 1 Then sh.Range("A" & i).EntireRow.Delete: i = i + 1
                    End If
                Next i

'Récupère le nombre de rangée dans le feuille
               sh.Activate
               ActiveSheet.Cells.SpecialCells(xlCellTypeLastCell).Activate
               iRws = ActiveCell.Row
               iCols = ActiveCell.Column
               rngEnd = sh.Cells(iRws, iCols).Address
               Set rngSource = sh.Range("A1:" & rngEnd)

'Trouves la dernière rangée dans la feuille de destination
               wbDestination.Activate
               Set wsDestination = ActiveSheet
               wsDestination.Cells.SpecialCells(xlCellTypeLastCell).Select
               totRws = ActiveCell.Row

'Vérifie qu'il y a assez de rangée libre dans la feuille de destination pour coller les données
               If totRws + rngSource.Rows.Count > wsDestination.Rows.Count Then
                  MsgBox "There are not enough rows to place the data in the Consolidation worksheet."
                  GoTo eh
               End If
'Ajoute une rangée pour coller les données dans la prochaine rangée vide
               If totRws <> 1 Then totRws = totRws + 1
               rngSource.Copy Destination:=wsDestination.Range("A" & totRws)
            Next sh
        End If

    Next wb

'Fermeture des classeurs ouverts à l'exception du classeur actif et du classeur personnel
   For Each wb In Application.Workbooks
      If wb.Name <> strDestName And wb.Name <> "PERSONAL.XLSB" Then
         wb.Close False
      End If
   Next wb

'Nettoyage des objets pour libérer la mémoire
   Set wbDestination = Nothing
   Set wbSource = Nothing
   Set wsDestination = Nothing
   Set rngSource = Nothing
   Set wb = Nothing
'Active la mise à jour de l'écran
   Application.ScreenUpdating = True
Exit Sub
eh:
MsgBox Err.Description
End Sub
Rechercher des sujets similaires à "recuperation donnees vba"