Discussion :

[CaptainTortue]

Bonjour à toutes et à tous,

J'ai besoin de votre aide pour réaliser une macro qui "copie/colle" des colonnes entières provenant de plusieurs feuilles du classeur, vers une feuille "synthèse".

Explications:
Le classeur en question récupère les données de 7 fichiers d'enregistrement (format .csv) et les placent dans 7 feuilles (onglets).
Le nom des fichiers d'enregistrement est de la forme: " 'Id de l'appareil' 'groupe de données' ('date'_'heure de debut'-'heure de fin') ", donc il varie. [voir photo]
J'ai tenté de faire une première macro (grâce à vous) en fouillant sur votre forum et en adaptant. J'en suis satisfait.

Mon problème est la 2e partie de mon projet.
Je dois récupérer les données de ces feuilles pour les placer dans une seule et même feuille. J'ai tenté la recherche sur le forum, mais je ne trouve pas mon bonheur. Enregistrer une macro qui répèterait les opérations "souris+clavier" ne me plait pas, ca fait pas "propre" et ca peut foirer.
Mais le VBA n'est pas mon dada (je suis une quiche).
Voilà pourquoi je fais appel à vous. [voir les 2 fichiers Excel]

Par avance, un immense merci.
CaptainTortue

[BENNASR]

bonjour et bienvenue
autodidacte et débutant VBA et ce code est inspiré d'un code fournie par Mr Jacques Boisgontier
à tester sur une copie de ton travail et j'assume aucune responsabilité en cas de perte de données

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

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
Sub regroup()
 
Application.ScreenUpdating = False
Dim w As Worksheet
Dim f2 As Worksheet
Set f2 = Sheets("SYNTHESE")
f2.Cells.ClearComments
Set d = CreateObject("Scripting.Dictionary")
For Each w In ThisWorkbook.Worksheets
    If w.Name <> "CONSOLIDER" And w.Name <> "SYNTHESE" Then
    TblBD = w.Range("A2:H" & w.Range("A" & Rows.Count).End(xlUp).Row)
    For i = 1 To UBound(TblBD)
    clé = TblBD(i, 1) & "|" & TblBD(i, 2)
    d(clé) = d(clé) & TblBD(i, 3) & "|" & TblBD(i, 4) & "|" & TblBD(i, 5) & "|" & TblBD(i, 6) & "|" & TblBD(i, 7) & "|" & TblBD(i, 8)
    Next i
    End If
    Next w
  f2.Range("A2").Resize(d.Count) = Application.Transpose(d.keys)
  f2.Range("C2").Resize(d.Count) = Application.Transpose(d.items)
  Application.DisplayAlerts = False
  f2.Range("A2").Resize(d.Count).TextToColumns Other:=1, OtherChar:="|"
  f2.Range("C2").Resize(d.Count).TextToColumns Other:=1, OtherChar:="|"
Application.ScreenUpdating = True
f2.Select
 
End Sub

[BENNASR]

tester ça :

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

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
Sub regroup()
Application.ScreenUpdating = False
Dim w As Worksheet
Dim f2 As Worksheet
Set f2 = Sheets("SYNTHESE")
f2.Cells.ClearComments
Set d = CreateObject("Scripting.Dictionary")
For Each w In ThisWorkbook.Worksheets
    If w.Name <> "CONSOLIDER" And w.Name <> "SYNTHESE" Then
    TblBD = w.Range("A2:H" & w.Range("A" & Rows.Count).End(xlUp).Row)
    For i = 1 To UBound(TblBD)
    clé = TblBD(i, 1) & "|" & TblBD(i, 2)
    d(clé) = d(clé) & "|" & TblBD(i, 3) & "|" & TblBD(i, 4) & "|" & TblBD(i, 5) & "|" & TblBD(i, 6) & "|" & TblBD(i, 7) & "|" & TblBD(i, 8)
    Next i
    End If
    Next w
  f2.Range("A2").Resize(d.Count) = Application.Transpose(d.keys)
  f2.Range("C2").Resize(d.Count) = Application.Transpose(d.items)
  Application.DisplayAlerts = False
  f2.Range("A2").Resize(d.Count).TextToColumns Other:=1, OtherChar:="|"
  f2.Range("C2").Resize(d.Count).TextToColumns Other:=1, OtherChar:="|"
 
  f2.Columns("C:C").Select
    Selection.Delete Shift:=xlToLeft
 
Application.ScreenUpdating = True
f2.Select
End Sub

[CaptainTortue]

Premièrement MERCI BENNASR,

La macro a l'air de fonctionner.
Juste une erreur à l'éxécution et un petit problème, la macro ne copie pas la première ligne. [voir photos]
La 1ere ligne correspond à l'entête de mon tableau (numéro d'échantillon, horodatage, nom du capteur)

A propos de du message d'erreur, le programme s'arrête sur "f2.Columns("C:C").Select"

Je pense qu'il n'y a que quelques petit trucs à changer et ce sera réglé.

CaptainTortue

[BENNASR]

plein de bricolage à tester

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

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
Sub regroup()
Application.ScreenUpdating = False
Dim w As Worksheet
Dim f2 As Worksheet
Dim Dercol As Long
Set f2 = Sheets("SYNTHESE")
f2.Cells.ClearContents
 
Dim unique As New Collection
Dim j As Long
Dim i As Long
On Error Resume Next
Set d = CreateObject("Scripting.Dictionary")
For Each w In ThisWorkbook.Worksheets
    If w.Name <> "CONSOLIDER" And w.Name <> "SYNTHESE" Then
     f2.Cells(1, 1) = w.Cells(1, 1)
      f2.Cells(1, 2) = w.Cells(1, 2)
    For C = 3 To 8
    unique.Add w.Cells(1, C).Value, CStr(w.Cells(1, C).Value)
    Next C
    End If
    TblBD = w.Range("A2:H" & w.Range("H" & Rows.Count).End(xlUp).Row)
    For i = 1 To UBound(TblBD)
    clé = TblBD(i, 1) & "|" & TblBD(i, 2)
    d(clé) = d(clé) & "|" & TblBD(i, 3) & "|" & TblBD(i, 4) & "|" & TblBD(i, 5) & "|" & TblBD(i, 6) & "|" & TblBD(i, 7) & "|" & TblBD(i, 8)
    Next i
    Next w
 f2.Range("A2").Resize(d.Count) = Application.Transpose(d.keys)
  f2.Range("C2").Resize(d.Count) = Application.Transpose(d.items)
  Application.DisplayAlerts = False
  f2.Range("A2").Resize(d.Count).TextToColumns Other:=1, OtherChar:="|"
  f2.Range("C2").Resize(d.Count).TextToColumns Other:=1, OtherChar:="|"
  On Error GoTo 0
  For j = 1 To unique.Count
   f2.Cells(j + 3) = unique(j)
   Next j
 f2.Activate
  f2.Columns("C:C").Select
 Selection.Delete Shift:=xlToLeft
 C = 3
Application.ScreenUpdating = True
f2.Select
End Sub

[CaptainTortue]

SUPER!
Tout fonctionne parfaitement!

Un grand merci à toi (et à Jacques Boisgontier)