Discussion :

[joel50]

Bonjour
Peu initié au VBA, j'ai avec l'aide de ce forum réalisé (ou recopié) ce bout de code qui recopie la dernière ligne de mes tableau de données sous tous les onglets commençant par Data_.

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
 
Sub ajoutavecdate()
 
Dim a, I As Byte
Dim Dt
Dt = Calendard.Chargement(Caption:="Entrer une date") ' InputBox("Entrer une date")
If Dt = False Then MsgBox "ERR": Exit Sub
 
For I = 1 To Sheets.Count
If InStr(1, Sheets(I).Name, "Data_") <> 0 Then
 With Sheets(I).ListObjects(1).Range
    .Rows(.Rows.Count).Copy .Rows(.Rows.Count + 1)
    .Cells(.Rows.Count + 1, 1) = TrouveType(Dt)
  End With
  End If
Next I
 
End Sub

Je voudrais sur cette dernière ligne crée (et uniquement sur celle-ci) que la macro fasse un couper/coller de certaines cellules, par ex couper les cellules des colonnes 82 à 90 pour les coller de 73 à 81.
Merci de votre aide
Joël

[Kimy_Ire]

Bonjour joel50,

Est-ce que quelque chose comme cela fonctionnerait :

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
Sub ajoutavecdate()
 
Dim a, I As Byte
Dim Dt
'Dt = Calendard.Chargement(Caption:="Entrer une date") ' InputBox("Entrer une date")
'If Dt = False Then MsgBox "ERR": Exit Sub
 
For I = 1 To Sheets.Count
    If InStr(1, Sheets(I).Name, "Data_") <> 0 Then
        With Sheets(I).ListObjects(1).Range
            .Rows(.Rows.Count).Copy .Rows(.Rows.Count + 1)
            '.Cells(.Rows.Count + 1, 1) = TrouveType(Dt)
 
            With .Rows(.Rows.Count + 1)
                For j = 73 To 81
                    .Cells(j) = .Cells(j + 9)
                    .Cells(j + 9) = ""
                Next j
            End With
        End With
    End If
Next I
 
End Sub

N'hésite pas à revenir vers moi !

Cordialement,
Kimy

[joel50]

Bonjour Kimy et merci

Ça répond exactement à ce que j'ai demandé, mais comme je n'ai pas bien posé ma question, ça ne fait pas tout à fait ce que je veux.

Ma macro recopie la dernière ligne sur tout mes onglets commençant par Data_, par contre je n'ai besoin de recopier des données que dans un des onglets, nommé Data_R.

Cordialement
Joël

[joel50]

Bonjour
J'ai réussi à arriver à mes fins en recopiant le bout de code autant de fois que d'onglets (heureusement que je n'en ai pas 50), comment faire pour compiler ce code proprement.

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
44
 
Sub ajoutavecdate()
 
Dim a, I As Byte
Dim Dt
'Dt = Calendard.Chargement(Caption:="Entrer une date") ' InputBox("Entrer une date")
'If Dt = False Then MsgBox "ERR": Exit Sub
 
For I = 1 To Sheets.Count
If InStr(1, Sheets(I).Name, "Data_S") <> 0 Then
 With Sheets(I).ListObjects(1).Range
    .Rows(.Rows.Count).Copy .Rows(.Rows.Count + 1)
   ' .Cells(.Rows.Count + 1, 1) = TrouveType(Dt)
 End With
  End If
Next I
 
For I = 1 To Sheets.Count
If InStr(1, Sheets(I).Name, "Data_I") <> 0 Then
 With Sheets(I).ListObjects(1).Range
    .Rows(.Rows.Count).Copy .Rows(.Rows.Count + 1)
    '.Cells(.Rows.Count + 1, 1) = TrouveType(Dt)
 End With
  End If
Next I
 
 
For I = 1 To Sheets.Count
    If InStr(1, Sheets(I).Name, "Data_R") <> 0 Then
        With Sheets(I).ListObjects(1).Range
            .Rows(.Rows.Count).Copy .Rows(.Rows.Count + 1)
           '.Cells(.Rows.Count + 1, 1) = TrouveType(Dt)
 
            With .Rows(.Rows.Count + 1)
                For j = 73 To 81
                    .Cells(j) = .Cells(j + 9)
                    .Cells(j + 9) = ""
                Next j
            End With
        End With
    End If
Next I
 
End Sub

Merci
Joël

[Theze]

Bonjour,

Voici un code un peu simplifié mais je ne l'ai pas testé :

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
 
Sub ajoutavecdate()
 
    Dim a, I As Byte
    Dim Dt
    'Dt = Calendard.Chargement(Caption:="Entrer une date") ' InputBox("Entrer une date")
    'If Dt = False Then MsgBox "ERR": Exit Sub
 
    For I = 1 To Sheets.Count
 
        If InStr(1, Sheets(I).Name, "Data_S") <> 0 Or _
            InStr(1, Sheets(I).Name, "Data_I") <> 0 Or _
            InStr(1, Sheets(I).Name, "Data_R") <> 0 Then
 
            With Sheets(I).ListObjects(1).Range
 
                .Rows(.Rows.Count).Copy .Rows(.Rows.Count + 1)
                '.Cells(.Rows.Count + 1, 1) = TrouveType(Dt)
 
            End With
 
            'cas particulier
            If InStr(1, Sheets(I).Name, "Data_R") <> 0 Then
 
                With .Rows(.Rows.Count + 1)
 
                    .Range(.Cells(73, 1), .Cells(81, 1)).Value = .Range(.Cells(82, 1), .Cells(90, 1)).Value
                    .Range(.Cells(82, 1), .Cells(90, 1)).Value = ""
 
                End With
 
            End If
 
        End If
 
    Next I
 
End Sub

Hervé.

[joel50]

Bonjour
Merci Hervé
Ton code Bug à la ligne With .Rows (.Rows.Count + 1) => Référence incorrecte ou non qualifiée

Entre deux j'ai modifié quelque peux ma feuille et fait quelques essai, je ne parvient toujours pas au bon résultat:

Le code bug sur la ligne Erreur d'exécution 1004
Erreur non définie par l'application de l'objet
Su r la ligne . Celle(.Rows.count +1,73) = Shettes("Fiche").Range("Nom....")
Le code ne va dons pas au bout et les calculs ne se réalisent pas.

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
 
Sub ajoutavecdate2()
 
Dim a, I, j As Byte
Dim Dt
Dt = Calendard.Chargement(Caption:="Entrer une date") ' InputBox("Entrer une date")
If Dt = False Then MsgBox "ERR": Exit Sub
 
For I = 1 To Sheets.Count
    If InStr(1, Sheets(I).Name, "Data_") <> 0 Then
        With Sheets(I).ListObjects(1).Range
            .Rows(.Rows.Count).Copy .Rows(.Rows.Count + 1)
            .Cells(.Rows.Count + 1, 1) = TrouveType(Dt)
        End With
    End If
Next I
 
       With Sheets("Data_Ration")
 
            .Cells(.Rows.Count + 1, 73) = Sheets("Fiche").Range("Nom_conc_Indiv_1_R_Corrigée")
            .Cells(.Rows.Count + 1, 74) = Sheets("Fiche").Range("Qté_jour_conc_Indiv_1_R_Corrigée")
            .Cells(.Rows.Count + 1, 75) = Sheets("Fiche").Range("prix_conc_Indiv_1_R_Corrigée")
            .Cells(.Rows.Count + 1, 76) = Sheets("Fiche").Range("Nom_conc_Indiv_2_R_Corrigée")
            .Cells(.Rows.Count + 1, 77) = Sheets("Fiche").Range("Qté_jour_conc_Indiv_2_R_Corrigée")
            .Cells(.Rows.Count + 1, 78) = Sheets("Fiche").Range("prix_conc_Indiv_2_R_Corrigée")
            .Cells(.Rows.Count + 1, 79) = Sheets("Fiche").Range("Nom_conc_Indiv_3_R_Corrigée")
            .Cells(.Rows.Count + 1, 80) = Sheets("Fiche").Range("Qté_jour_conc_Indiv_3_R_Corrigée")
            .Cells(.Rows.Count + 1, 81) = Sheets("Fiche").Range("prix_conc_Indiv_3_R_Corrigée")
 
                With .Rows(.Rows.Count + 1)
                    For j = 39 To 55
                        .Cells(j) = .Cells(j + 15)
                    Next j
                End With
       End With
 
End Sub

Le code ne bug pas à l’exécution mais me copie 3 données en 39 et 40 sortant de je ne sait d’où (un 0 en 39 et 00/01/1900 en 40)

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
44
45
46
47
48
49
50
51
52
53
54
 
Sub ajoutavecdate4()
 
Dim a, I As Byte
Dim Dt
Dt = Calendard.Chargement(Caption:="Entrer une date") ' InputBox("Entrer une date")
If Dt = False Then MsgBox "ERR": Exit Sub
 
For I = 1 To Sheets.Count
If InStr(1, Sheets(I).Name, "Data_S") <> 0 Then
 With Sheets(I).ListObjects(1).Range
    .Rows(.Rows.Count).Copy .Rows(.Rows.Count + 1)
    .Cells(.Rows.Count + 1, 1) = TrouveType(Dt)
 End With
  End If
Next I
 
For I = 1 To Sheets.Count
If InStr(1, Sheets(I).Name, "Data_I") <> 0 Then
 With Sheets(I).ListObjects(1).Range
    .Rows(.Rows.Count).Copy .Rows(.Rows.Count + 1)
    .Cells(.Rows.Count + 1, 1) = TrouveType(Dt)
 End With
  End If
Next I
 
 
For I = 1 To Sheets.Count
    If InStr(1, Sheets(I).Name, "Data_R") <> 0 Then
        With Sheets(I).ListObjects(1).Range
            .Rows(.Rows.Count).Copy .Rows(.Rows.Count + 1)
           '.Cells(.Rows.Count + 1, 1) = TrouveType(Dt)
 
            .Cells(.Rows.Count + 1, 73) = Sheets("Fiche").Range("Nom_conc_Indiv_1_R_Corrigée")
            .Cells(.Rows.Count + 1, 74) = Sheets("Fiche").Range("Qté_jour_conc_Indiv_1_R_Corrigée")
            .Cells(.Rows.Count + 1, 75) = Sheets("Fiche").Range("prix_conc_Indiv_1_R_Corrigée")
            .Cells(.Rows.Count + 1, 76) = Sheets("Fiche").Range("Nom_conc_Indiv_2_R_Corrigée")
            .Cells(.Rows.Count + 1, 77) = Sheets("Fiche").Range("Qté_jour_conc_Indiv_2_R_Corrigée")
            .Cells(.Rows.Count + 1, 78) = Sheets("Fiche").Range("prix_conc_Indiv_2_R_Corrigée")
            .Cells(.Rows.Count + 1, 79) = Sheets("Fiche").Range("Nom_conc_Indiv_3_R_Corrigée")
            .Cells(.Rows.Count + 1, 80) = Sheets("Fiche").Range("Qté_jour_conc_Indiv_3_R_Corrigée")
            .Cells(.Rows.Count + 1, 81) = Sheets("Fiche").Range("prix_conc_Indiv_3_R_Corrigée")
 
            With .Rows(.Rows.Count + 1)
                For j = 39 To 55
                    .Cells(j) = .Cells(j + 15)
                    '.Cells(j + 9) = ""
                Next j
            End With
        End With
    End If
Next I
 
End Sub

si dessous code de la fonction trouvetype, si ça peut aider.

Code :

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

1
2
3
4
5
6
7
 
Function TrouveType(V)
TrouveType = V
If IsDate(TrouveType) = True And InStr(TrouveType, "/") <> 0 And InStr(TrouveType, ":") <> 0 Then TrouveType = Format(TrouveType, "yyyy-mm-dd hh:mm"): Exit Function
If IsDate(TrouveType) = True And InStr(TrouveType, "/") <> 0 Then TrouveType = Format(TrouveType, "yyyy-mm-dd"): Exit Function
If IsNumeric(Replace(TrouveType, ".", ",")) = True Then TrouveType = Replace(TrouveType, ",", "."): Exit Function
End Function

Joint fichier extrait de mon fichier global qui devrait faciliter la compréhension;

Cordialement
Joël

[Theze]

Oups,

Une End With mal placé, celui de "With Sheets(I).ListObjects(1).Range" :

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
 
Sub ajoutavecdate()
 
    Dim a, I As Byte
    Dim Dt
    'Dt = Calendard.Chargement(Caption:="Entrer une date") ' InputBox("Entrer une date")
    'If Dt = False Then MsgBox "ERR": Exit Sub
 
    For I = 1 To Sheets.Count
 
        If InStr(1, Sheets(I).Name, "Data_S") <> 0 Or _
            InStr(1, Sheets(I).Name, "Data_I") <> 0 Or _
            InStr(1, Sheets(I).Name, "Data_R") <> 0 Then
 
            With Sheets(I).ListObjects(1).Range
 
                .Rows(.Rows.Count).Copy .Rows(.Rows.Count + 1)
                '.Cells(.Rows.Count + 1, 1) = TrouveType(Dt)
 
               'cas particulier
               If InStr(1, Sheets(I).Name, "Data_R") <> 0 Then
 
                   With .Rows(.Rows.Count + 1)
 
                       .Range(.Cells(73, 1), .Cells(81, 1)).Value = .Range(.Cells(82, 1), .Cells(90, 1)).Value
                       .Range(.Cells(82, 1), .Cells(90, 1)).Value = ""
 
                   End With
 
               End If
 
            End With
 
        End If
 
    Next I
 
End Sub

Hervé.

[joel50]

Merci Hervé
Réponse entre temps, je regarde.
Cordialement
Joël

[Kimy_Ire]

Bonjour joel50,

Voici :

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 ajoutavecdate()
 
Dim a, I As Byte
Dim Dt
'Dt = Calendard.Chargement(Caption:="Entrer une date") ' InputBox("Entrer une date")
'If Dt = False Then MsgBox "ERR": Exit Sub
 
For I = 1 To Sheets.Count
    If InStr(1, Sheets(I).Name, "Data_") <> 0 Then
        With Sheets(I).ListObjects(1).Range
            .Rows(.Rows.Count).Copy .Rows(.Rows.Count + 1)
            '.Cells(.Rows.Count + 1, 1) = TrouveType(Dt)
 
            If Sheets(I).Name = "Data_R" then
                With .Rows(.Rows.Count + 1)
                    For j = 73 To 81
                        .Cells(j) = .Cells(j + 9)
                        .Cells(j + 9) = ""
                    Next j
                End With
            End If
        End With
    End If
Next I
 
End Sub

Cordialement,
Kimy

[joel50]

Bonjour Kimy
Merci à tous les 2

Kimy, ton code est ok, super, merci.
Hervé, la seconde partie du code ne fonctionne pas, je n'ai pas testé mais je pense que le souci provient de la ligne 20 concernant le nom de l'onglet.

Code adapté au tableur ci-dessus, pour ce que je veux y faire.

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
Sub ajoutavecdate()
 
Dim a, I As Byte
Dim Dt
Dt = Calendard.Chargement(Caption:="Entrer une date") ' InputBox("Entrer une date")
If Dt = False Then MsgBox "ERR": Exit Sub
 
For I = 1 To Sheets.Count
    If InStr(1, Sheets(I).Name, "Data_") <> 0 Then
        With Sheets(I).ListObjects(1).Range
            .Rows(.Rows.Count).Copy .Rows(.Rows.Count + 1)
            .Cells(.Rows.Count + 1, 1) = TrouveType(Dt)
 
            If Sheets(I).Name = "Data_Ration" Then
                With .Rows(.Rows.Count + 1)
                    For j = 56 To 72
                        .Cells(j) = .Cells(j - 17)
                    Next j
                    For L = 82 To 90
                        .Cells(L) = ""
                    Next L
                    End With
            .Cells(.Rows.Count + 1, 73) = Sheets("Fiche").Range("Nom_conc_Indiv_1_R_Corrigée")
            .Cells(.Rows.Count + 1, 74) = Sheets("Fiche").Range("Qté_jour_conc_Indiv_1_R_Corrigée")
            .Cells(.Rows.Count + 1, 75) = Sheets("Fiche").Range("prix_conc_Indiv_1_R_Corrigée")
            .Cells(.Rows.Count + 1, 76) = Sheets("Fiche").Range("Nom_conc_Indiv_2_R_Corrigée")
            .Cells(.Rows.Count + 1, 77) = Sheets("Fiche").Range("Qté_jour_conc_Indiv_2_R_Corrigée")
            .Cells(.Rows.Count + 1, 78) = Sheets("Fiche").Range("prix_conc_Indiv_2_R_Corrigée")
            .Cells(.Rows.Count + 1, 79) = Sheets("Fiche").Range("Nom_conc_Indiv_3_R_Corrigée")
            .Cells(.Rows.Count + 1, 80) = Sheets("Fiche").Range("Qté_jour_conc_Indiv_3_R_Corrigée")
            .Cells(.Rows.Count + 1, 81) = Sheets("Fiche").Range("prix_conc_Indiv_3_R_Corrigée")
 
 
            End If
        End With
    End If
Next I
 
End Sub

Cordialement
Joël