1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78
| Sub CopierValeurs()
Dim ws As Worksheet
Dim rng As Range
Dim cell As Range
Dim wb As Workbook
Dim destWs As Worksheet
Dim destCell As Range
Dim dict As Object
Dim key As Variant
Dim values As Object
Dim value As Variant
Dim NbCol As Long
Dim i As Long
' Désactiver l'affichage des fenêtres
Application.ScreenUpdating = False
Set ws = ThisWorkbook.Sheets("Feuil1") ' Remplacez "Feuil1" si nécessaire
NbCol = ws.Cells(1, ws.Columns.Count).End(xlToLeft).Column - 2 ' Nombre de colonnes de valeurs
Set rng = ws.Range(ws.Cells(2, 1), ws.Cells(ws.Rows.Count, "A").End(xlUp).Resize(, NbCol))
' Créer un dictionnaire pour regrouper les valeurs par fichier
Set dict = CreateObject("Scripting.Dictionary")
' Parcourir chaque cellule de la plage
For Each cell In rng
If cell.value <> "" Then
' Créer la clé du dictionnaire
key = ws.Cells(cell.Row, NbCol + 1).value & ws.Cells(cell.Row, NbCol + 2).value
' Ajouter la valeur à la liste pour cette clé
If dict.Exists(key) Then
dict(key).Add cell.Address(False, False) & ":" & cell.value
Else
Set dict(key) = CreateObject("System.Collections.ArrayList")
dict(key).Add cell.Address(False, False) & ":" & cell.value
End If
End If
Next cell
' Parcourir chaque clé du dictionnaire
For Each key In dict.Keys
' Ouvrir le classeur de destination
On Error Resume Next ' Ignorer l'erreur si le fichier n'existe pas
Set wb = Workbooks.Open(key)
On Error GoTo 0 ' Réactiver les erreurs
' Si le classeur de destination n'existe pas, le créer
If wb Is Nothing Then
Set wb = Workbooks.Add
wb.SaveAs key
End If
' Définir la feuille de travail et la cellule de destination
Set destWs = wb.Sheets(1)
' Copier les titres dans le classeur de destination
If destWs.Cells(1, 1).value = "" Then
ws.Range(ws.Cells(1, 1), ws.Cells(1, NbCol)).Copy destWs.Cells(1, 1)
End If
' Copier les valeurs dans les cellules de destination
Set values = dict(key)
For Each value In values
Set destCell = destWs.Range(Split(value, ":")(0))
destCell.value = Split(value, ":")(1)
Next value
' Sauvegarder et fermer le classeur de destination
wb.Close SaveChanges:=True
Set wb = Nothing
Next key
Application.ScreenUpdating = True
MsgBox "Traitement terminé!", vbInformation
End Sub |
Partager