Discussion :

[lewizard60]

Bonjour tout le monde,

Mon problème est assez simple.

J'aimerai copier quelques colonnes identiques sur chaque feuilles dans une autre feuille et que le tout se mette a la suite.

J'ai joint le fichier en question Plans_cave_scan_access.xlsx et j'aimerai que les données de toutes les feuilles commencant par 00303 jusqu'a la fin arrivent comme la représentation sur la feuille transfert.

Est ce que quelqu'un pourrait m'aider !! Merci d'avance.

[keygen08]

Bonjour

Voila un début d'idée

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
Private Sub devellopez_com()
 Dim i As Integer, j As Integer
 Dim Feuil As String
 Dim lig As Integer
 Dim lig2 As Integer
 Dim lig3 As Integer
 
 i = ActiveWorkbook.Sheets.Count
 
 For j = 7 To i
 
 Feuil = Worksheets(j).Name
 
 lig = Feuil1.Range("g65000").End(xlUp).Row + 2
 
 Feuil1.Range("a" & lig).Value = Feuil
 Feuil1.Range("b" & lig).Value = Sheets(Feuil).Range("d2").Value
 Feuil1.Range("c" & lig).Value = Sheets(Feuil).Range("c9").Value
 Feuil1.Range("d" & lig).Value = "DGO " & Sheets(Feuil).Range("a2").Value
 
lig1 = Sheets(Feuil).Range("a9").End(xlDown).Row
lig2 = Sheets(Feuil).Range("a65000").End(xlUp).Row
lig3 = Feuil1.Range("g65000").End(xlUp).Row
Sheets(Feuil).Range("a9:d11").Copy Feuil1.Range("e" & lig)
 
 Next j
 
End Sub

J'aime bien le "Assez simple"

[lewizard60]

Merci beaucoup pour ton aide.

Je viens de tester le code et il me sort superbement bien les données concernant le nivellement. Je vais l'adapter pour les autres données.

Je te remercie grandement pour ton aide apportée.

[keygen08]

Bonsoir

Celle ci est complete, il reste la mise en page et la verification a 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
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
Private Sub devellopez_com()
 Dim i As Integer, j As Integer
 Dim Feuil As String
 Dim lig As Integer
 Dim lig2 As Integer
 Dim plan As Integer
 Dim archive As Integer
application.screenupdating = false
 
 i = ActiveWorkbook.Sheets.Count
 
 For j = 7 To i
 
 Feuil = Worksheets(j).Name
 
 lig = Feuil1.Range("g65000").End(xlUp).Row + 2
 
 Feuil1.Range("a" & lig).Value = Feuil
 Feuil1.Range("b" & lig).Value = Sheets(Feuil).Range("d2").Value
 Feuil1.Range("c" & lig).Value = Sheets(Feuil).Range("c9").Value
 Feuil1.Range("d" & lig).Value = "DGO " & Sheets(Feuil).Range("a2").Value
 
lig2 = Sheets(Feuil).Range("A12").End(xlUp).Row
If lig2 = 8 Then
lig2 = 9
End If
 
For plan = 9 To lig2
If Sheets(Feuil).Range("c" & plan) <> "" Then
Sheets(Feuil).Range("a" & plan & ":b" & plan).UnMerge
Sheets(Feuil).Range("a" & plan & ":d" & plan).Copy Feuil1.Range("e" & lig)
Sheets(Feuil).Range("a" & plan & ":b" & plan).Merge True
lig = lig + 1
End If
Next plan
 
lig1 = Sheets(Feuil).Range("A65000").End(xlUp).Row
    If lig1 = 15 Then
    lig1 = 16
    End If
 
For archive = 16 To lig1
If Sheets(Feuil).Range("c" & archive) <> "" Then
 Feuil1.Range("a" & lig).Value = Feuil
 Feuil1.Range("b" & lig).Value = Sheets(Feuil).Range("d2").Value
 Feuil1.Range("c" & lig).Value = Sheets(Feuil).Range("c9").Value
 Feuil1.Range("d" & lig).Value = "DGO " & Sheets(Feuil).Range("a2").Value
 
    Sheets(Feuil).Range("a" & archive & ":b" & archive).UnMerge
    Sheets(Feuil).Range("a" & archive & ":d" & archive).Copy Feuil1.Range("e" & lig)
    Sheets(Feuil).Range("a" & archive & ":b" & archive).Merge True
    Feuil1.Range("E" & lig).Cut Destination:=Feuil1.Range("F" & lig)
 lig = lig + 1
End If
Next archive
 
 Next j
application.screenupdating = true
End Sub

Une fois lancer, cela mouline un peu, 288 feuille !!(en gros dix mn)
La feuille 2965 provoque deux erreur a cause des donnees contenu a la fois dans la colonne A et B

[lewizard60]

Un grand merci pour cette aide :-)