[XL-2010] archivage tableau - boucle [Résolu]

[chacha49]

Bonjour,

Je cherche à archiver un formulaire de type facture composé de la façon suivante :

un entête
un tableau de A2737

J'souhaite pour chaque ligne du tableau, ajouter dans le fichier d'archive les informations de l'entête.

J'arrive le faire pour la premiere ligne du tableau mais pas pour le reste. Je pense qu'il faudrait utiliser une boucle supplémentaire mais je ne sais ni comment l'intégrer ni laquelle utiliser... et je pense qu'il doit y avoir plus simple que ce que j'ai fait

Merci d'avance

Voici une partie du code utilisé :

Code :

1
2
3
4
5
6
7
8
9
10
11
12
13
Sheets("Donnees_archive_sst").Select
Range("A2").Select
 
Do
If ActiveCell = "" Then
GoTo Archive
End If
 
If ActiveCell <> "" Then
ActiveCell.Offset(1, 0).Select
End If
 
Loop Until ActiveCell.Value = ""

Archive:

Code :

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
'en tête'
 
ActiveCell.Value = Sheets("Avoir").Range("L1").Value
ActiveCell.Offset(0, 1).Select
ActiveCell.Value = Sheets("Avoir").Range("M3").Value
ActiveCell.Offset(0, 1).Select
ActiveCell.Value = Sheets("Avoir").Range("D10").Value
ActiveCell.Offset(0, 1).Select
ActiveCell.Value = Sheets("Avoir").Range("D12").Value
ActiveCell.Offset(0, 1).Select
ActiveCell.Value = Sheets("Avoir").Range("D16").Value
ActiveCell.Offset(0, 1).Select
 
ActiveCell.Value = Sheets("Avoir").Range("D22").Value
ActiveCell.Offset(0, 1).Select
ActiveCell.Value = Sheets("Avoir").Range("F22").Value
ActiveCell.Offset(0, 1).Select
ActiveCell.Value = Sheets("Avoir").Range("E24").Value
ActiveCell.Offset(0, 1).Select
ActiveCell.Value = Sheets("Avoir").Range("L24").Value
ActiveCell.Offset(0, 1).Select
 
'tableau'
 
ActiveCell.Value = Sheets("Avoir").Range("A27").Value
ActiveCell.Offset(0, 1).Select
ActiveCell.Value = Sheets("Avoir").Range("B27").Value
ActiveCell.Offset(0, 1).Select
ActiveCell.Value = Sheets("Avoir").Range("C27").Value
ActiveCell.Offset(0, 1).Select
ActiveCell.Value = Sheets("Avoir").Range("D27").Value
ActiveCell.Offset(0, 1).Select
ActiveCell.Value = Sheets("Avoir").Range("E27").Value
ActiveCell.Offset(0, 1).Select
ActiveCell.Value = Sheets("Avoir").Range("F27").Value
ActiveCell.Offset(0, 1).Select
ActiveCell.Value = Sheets("Avoir").Range("G27").Value
ActiveCell.Offset(0, 1).Select
ActiveCell.Value = Sheets("Avoir").Range("H27").Value
ActiveCell.Offset(0, 1).Select
ActiveCell.Value = Sheets("Avoir").Range("I27").Value
ActiveCell.Offset(0, 1).Select
ActiveCell.Value = Sheets("Avoir").Range("J27").Value
ActiveCell.Offset(0, 1).Select
ActiveCell.Value = Sheets("Avoir").Range("K27").Value
ActiveCell.Offset(0, 1).Select
ActiveCell.Value = Sheets("Avoir").Range("L27").Value
ActiveCell.Offset(0, 1).Select
ActiveCell.Value = Sheets("Avoir").Range("M27").Value
ActiveCell.Offset(0, 1).Select
ActiveCell.Value = Sheets("Avoir").Range("N27").Value
ActiveCell.Offset(0, 1).Select
ActiveCell.Value = Sheets("Avoir").Range("O27").Value
ActiveCell.Offset(0, 1).Select
ActiveCell.Value = Sheets("Avoir").Range("P27").Value
ActiveCell.Offset(0, 1).Select

[mercatog]

Bonjour

Code :

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
Sub Archivage()
Dim Sh As Worksheet
Dim NewLig As Long
Dim i As Byte
Dim Tb
 
Application.ScreenUpdating = False
With Sheets("Donnees_archive_sst")
    NewLig = .Cells(.Rows.Count, "A").End(xlUp).Row + 1
    Set Sh = Worksheets("Avoir")
    'entêtes
    Tb = Array("L1", "M3", "D10", "D12", "D16", "D22", "F22", "E24", "L24")
    For i = 0 To 8
        .Cells(NewLig, i + 1).Value = Sh.Range(Tb(i)).Value
    Next i
    'tableau'
    .Range("J" & NewLig & ":Y" & NewLig).Value = Sh.Range("A27:P27").Value
    Set Sh = Nothing
End With
End Sub

[chacha49]

Merci de la réponse c'est effectivement beaucoup plus court que ce que j'ai fait!

Par contre il ne va pas chercher les lignes suivantes dans le tableau et ne copie donc que la premiere ligne.

c'est peut être beaucoup demander, mais serait il possible d'avoir les explications de la formule, histoire d'être capable de la refaire une prochaine fois.

Merci encore

[mercatog]

Une première proposition

Code :

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
Sub Archivage()
Dim Sh As Worksheet
Dim NewLig As Long
Dim LastLig As Integer, i As Integer, j As Integer
Dim Tb
 
Application.ScreenUpdating = False
With Sheets("Donnees_archive_sst")
    Set Sh = Worksheets("Avoir")
'entêtes
    Tb = Array("L1", "M3", "D10", "D12", "D16", "D22", "F22", "E24", "L24")
    LastLig = Sh.Cells(Sh.Rows.Count, "A").End(xlUp).Row
    If LastLig >= 27 Then
        NewLig = .Cells(.Rows.Count, "A").End(xlUp).Row + 1
        For i = 0 To 8
            .Range(.Cells(NewLig, i + 1), .Cells(NewLig + LastLig - 27, i + 1)).Value = Sh.Range(Tb(i)).Value
        Next i
'tableau'
        .Range("J" & NewLig & ":Y" & NewLig + LastLig - 27).Value = Sh.Range("A27:P" & LastLig).Value
    End If
    Set Sh = Nothing
End With
End Sub

[chacha49]

Merci beaucoup!

Ca fonctionne très bien!