Excel 2016 VBA - Récupérer données fixes sur différentes feuilles
Bonjour à tous,
Tout d'abord pardon pour la demande qui a été posée à de multiples reprises sur internet à ce sujet ; débutant en VBA, j'essaie d'apprendre par moi-même mais ce n'est pas évident, et je me retrouve bloqué et un peu désemparé !
Je gère un fichier Excel qui contient plusieurs feuilles :
- Feuille 1 : feuille destination qui centralise toutes les données à reprendre dans les feuilles 2, 3, 4, 5 et 6, avec un header identique à toutes ces mêmes feuilles, sur 2 lignes et 28 colonnes ;
- Feuilles 2, 3, 4, 5 et 6 : feuilles sources dont les données sont saisies manuellement dans le respect du header partagé sur 2 lignes et 28 colonnes ;
- Feuilles 7, 8, 9 et 10 : données différentes à exclure.
Mon objectif est assez simple sur le papier : automatiser via VBA la reprise des données des feuilles 2, 3, 4, 5 et 6
- A partir de la ligne 3 jusqu'à la dernière saisie et de la colonne 1 à la colonne 28 ;
- Intégrer les données copiées sur la feuille 1 ;
- Intégrer dans la requête un "Clear" de la feuille 1 sans toucher au Header (donc clear de la ligne 3-dernière ligne saisie & colonne 1 à 28).
Pour ce faire, j'ai utilisé la requête suivante, mais celle-ci ne m'apporte pas satisfaction (la complétion des critères a certainement été effectué d'une mauvaise manière, je l'admets) : bien que le header semble préservé, les données sont éparses et ne sont pas reprises au bon endroit, une partie du header des fichiers sources est reprise... bref, c'est chaotique.
Voici la requête :
Sub CopyFromMultiShts()
Dim wsMain As Worksheet
Dim wsExclude As Worksheet
Dim rngColHeaders As Range
Dim ws As Worksheet
Dim lngNextRow As Long
Dim cel As Range
Dim rngToFind As Range
Dim rngDestin As Range
Dim rngToCopy As Range
Set wsMain = Worksheets("Feuille 1") 'Edit "Main data" to your output worksheet name
Set wsExclude = Worksheets("Feuille 7") 'Edit "Exclude List" to worksheet with list of worksheets to exclude
Set wsExclude = Worksheets("Feuille 8")
Set wsExclude = Worksheets("Feuille 9")
Set wsExclude = Worksheets("Feuille 10")
With wsMain
'Assign Column Headers of Main data sheet to a range variable
Set rngColHeaders = .Range(.Cells(1, 2), .Cells(1, .Columns.Count).End(xlToLeft))
'**************************************************************************************
Rows("3:" & Rows.Count).ClearContents 'Optional to clear existing data first.
'**************************************************************************************
End With
For Each ws In Worksheets 'Loop through worksheets
If WorksheetFunction.CountIf(wsExclude.Columns("A:A"), ws.Name) = 0 Then 'Equal zero then not in exclude list
lngNextRow = LastRowOrCol(True, wsMain.Cells) + 1 'Next blank row in Main data worksheet
With ws
'Assign column headers of source worksheet to a range variable
Set rngColHeaders = .Range(.Cells(1, 2), .Cells(1, .Columns.Count).End(xlToLeft))
For Each cel In rngColHeaders 'Loop through column headers in source worksheet
If WorksheetFunction.CountA(cel.EntireColumn) > 1 Then 'If more than column header data exists
With wsMain 'Start of nested With/End With
'Search for column header in Main data worksheet
Set rngToFind = .Rows(1).Find(What:=cel.Value, _
LookIn:=xlFormulas, _
LookAt:=xlWhole, _
SearchOrder:=xlByRows, _
SearchDirection:=xlNext, _
MatchCase:=False)
If rngToFind Is Nothing Then GoTo SkipCopy 'If Nothing then column header not found so skip copy
'Next blank row in Main data (lngNextRow from above) and column where column header found
Set rngDestin = .Cells(lngNextRow, rngToFind.Column)
End With 'End nested With/End With
'Assign data from source worksheet to a range variable (From cell below column header to bottom of data)
Set rngToCopy = .Range(cel.Offset(1, 3), .Cells(.Rows.Count, cel.Column).End(xlUp))
'Copy column from source worksheet to Main data worksheet
rngToCopy.Copy Destination:=rngDestin
End If
SkipCopy:
Next cel
End With
End If
Next ws
wsMain.Columns.AutoFit 'Optional code
End Sub
Function LastRowOrCol(bolRowOrCol As Boolean, Optional rng As Range) As Long
'Finds the last used row or column in a worksheet
'First parameter is True for Last Row or False for last Column
'Third parameter is optional
'Must be specified if not ActiveSheet
Dim lngRowCol As Long
Dim rngToFind As Range
If rng Is Nothing Then
Set rng = ActiveSheet.Cells
End If
If bolRowOrCol Then
lngRowCol = xlByRows
Else
lngRowCol = xlByColumns
End If
With rng
Set rngToFind = rng.Find(What:="*", _
LookIn:=xlFormulas, _
LookAt:=xlPart, _
SearchOrder:=lngRowCol, _
SearchDirection:=xlPrevious, _
MatchCase:=False)
End With
If Not rngToFind Is Nothing Then
If bolRowOrCol Then
LastRowOrCol = rngToFind.Row
Else
LastRowOrCol = rngToFind.Column
End If
End If
End FunctionJ'ai récupéré cette requête sur le web anglophone ; elle peut très certainement être simplifiée pour mon besoin.
Si quelqu'un peut me proposer des points d'amélioration ou de simplification sur cette requête, je suis preneur :)
Merci pour votre aide !
Bonjour,
Il est probable que vous devrez fournir le classeur en question si bous attendez une réponse.
A+
Bonjour,
Merci pour votre retour. Hélas le fichier est d'une part assez volumineux et les données contenues confidentielles ; l'anonymisation de celles-ci risque d'être fastidieux.
En comparant initialement avec les autres posts de ce type, je ne vois pas les personnes poster leur classeur systématiquement. Je comprends la demande néanmoins. Si cela signifie que je ne pourrais obtenir de l'aide, tant pis pour moi, j'aurais essayé :)
Merci à vous.
MAJ :
Solution obtenue sur un forum anglophone :
Sub CopyData()
Application.ScreenUpdating = False
Dim desWS As Worksheet, x As Long
Set desWS = Sheets(1)
desWS.UsedRange.Offset(2).ClearContents
For x = 2 To 6
With desWS
Sheets(x).UsedRange.Offset(2).Copy .Cells(.Rows.Count, "A").End(xlUp).Offset(1)
End With
Next x
Application.ScreenUpdating = True
End SubSi ça peut servir à quelqu'un d'autre à l'avenir, tant mieux !
Bonne journée.