Macro VBA Synthèse

Version imprimable

Macro VBA Synthèse

Bonjour,
Découvrant et apprenant VBA comme je peux, j'ai repris un bout de code et adapté à mon projet qui est de reprendre plusieurs feuilles d'une fichier excel en une seule selon certaines colonnes avec la source indiqué dans une autre colonne, le programme est ci-dessous, sauf que pour la source celle-ci est copiée jusqu'a la fin du tableau donc le maximum de lignes dans excel, ce qui ne laisse pas de place pour les autres feuilles, voici le code :

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
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
Sub Macro5()
 
    Dim sh As Worksheet
    Dim DestSh As Worksheet
    Dim Last As Long
    Dim CopyRng As Range
 
    With Application
        .ScreenUpdating = False
        .EnableEvents = False
        End With
    Application.DisplayAlerts = False
    On Error Resume Next
    ActiveWorkbook.Worksheets("RDBMergeSheet").Delete
    On Error GoTo 0
    Application.DisplayAlerts = True
    'Add a worksheet with the name "RDBMergeSheet"
    Set DestSh = ActiveWorkbook.Worksheets.Add
    DestSh.Name = "RDBMergeSheet"
 
    'Passe tout les fichiers en vue et trouve la dernière ligne
    For Each sh In ActiveWorkbook.Worksheets
            If sh.Name = "Piste Audit Matisse" Then
 
            'Find the last Row with data on the DestSh
            Last = LastRow(DestSh)
 
            'Fill in the range(s) that you want to copy
           Set CopyRng = sh.Range("C:C")
 
            'Test if there enough rows in the DestSh to copy all the data
            If Last + CopyRng.Rows.Count > DestSh.Rows.Count Then
                MsgBox "There are not enough rows in the Destsh"
                GoTo ExitTheSub
                End If
            'This example copies values/formats and Column width
            CopyRng.Copy
            With DestSh.Cells(1, Last + 1)
                .PasteSpecial 8
                .PasteSpecial xlPasteValues
                .PasteSpecial xlPasteFormats
                Application.CutCopyMode = False
            End With
 
            DestSh.Cells(Last + 1, "D").Value = sh.Name 'Resize(CopyRng.Rows.Count).
 
        End If
    Next
ExitTheSub:
With Application
        .ScreenUpdating = True
        .EnableEvents = True
        End
End With
End Sub
Function LastCol(sh As Worksheet)
    On Error Resume Next
    LastCol = sh.Cells.Find(What:="*", _
                            After:=sh.Range("A1"), _
                            Lookat:=xlPart, _
                            LookIn:=xlFormulas, _
                            SearchOrder:=xlByColumns, _
                            SearchDirection:=xlPrevious, _
                            MatchCase:=False).Column
    On Error GoTo 0
End Function
Function LastRow(sh As Worksheet)
    On Error Resume Next
    LastRow = sh.Cells.Find(What:="*", _
                            After:=sh.Range("A1"), _
                            Lookat:=xlPart, _
                            LookIn:=xlFormulas, _
                            SearchOrder:=xlByRows, _
                            SearchDirection:=xlPrevious, _
                            MatchCase:=False).Row
    On Error GoTo 0
End Function

Les deux fonctions ci dessous copie soit en fonction de la dernière lignes ou colonnes, j'ai esseyé les deux fonctions le résultat est le même :/
çela fonctionne très bien pour copier les données mais j'aimerais que la source s'arrête au même nombre de lignes que de données et non pas le nombre max de lignes dans excel.
Je vous remercie d'avance

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
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
Sub Macro5()
 
    Dim sh As Worksheet
    Dim DestSh As Worksheet
    Dim Last As Long
    Dim CopyRng As Range
 
    With Application
        .ScreenUpdating = False
        .EnableEvents = False
        End With
    Application.DisplayAlerts = False
    On Error Resume Next
    ActiveWorkbook.Worksheets("RDBMergeSheet").Delete
    On Error GoTo 0
    Application.DisplayAlerts = True
    'Add a worksheet with the name "RDBMergeSheet"
    Set DestSh = ActiveWorkbook.Worksheets.Add
    DestSh.Name = "RDBMergeSheet"
 
    'Passe tout les fichiers en vue et trouve la dernière ligne
    For Each sh In ActiveWorkbook.Worksheets
            If sh.Name = "Piste Audit Matisse" Then
 
            'Find the last Row with data on the DestSh
            Last = LastRow(DestSh)
 
            'Fill in the range(s) that you want to copy
           Set CopyRng = sh.Range("C:C")
 
            'Test if there enough rows in the DestSh to copy all the data
            If Last + CopyRng.Rows.Count > DestSh.Rows.Count Then
                MsgBox "There are not enough rows in the Destsh"
                GoTo ExitTheSub
                End If
            'This example copies values/formats and Column width
            CopyRng.Copy
            With DestSh.Cells(1, Last + 1)
                .PasteSpecial 8
                .PasteSpecial xlPasteValues
                .PasteSpecial xlPasteFormats
                Application.CutCopyMode = False
            End With
 
            DestSh.Cells(Last + 1, "D").Value = sh.Name 'Resize(CopyRng.Rows.Count).
 
        End If
    Next
ExitTheSub:
With Application
        .ScreenUpdating = True
        .EnableEvents = True
        End
End With
End Sub
Function LastCol(sh As Worksheet)
    On Error Resume Next
    LastCol = sh.Cells.Find(What:="*", _
                            After:=sh.Range("A1"), _
                            Lookat:=xlPart, _
                            LookIn:=xlFormulas, _
                            SearchOrder:=xlByColumns, _
                            SearchDirection:=xlPrevious, _
                            MatchCase:=False).Column
    On Error GoTo 0
End Function
Function LastRow(sh As Worksheet)
    On Error Resume Next
    LastRow = sh.Cells.Find(What:="*", _
                            After:=sh.Range("A1"), _
                            Lookat:=xlPart, _
                            LookIn:=xlFormulas, _
                            SearchOrder:=xlByRows, _
                            SearchDirection:=xlPrevious, _
                            MatchCase:=False).Row
    On Error GoTo 0
End Function

Ca fait bcp de code pour pas grand chose

Si tu veux choper la derniere ligne de tout , tu peux utiliser un

Code:

usedrange

par exemple

Code:

thisworkbook.worksheets(nom).usedrange.rows.count ou thisworkbook.worksheets(nom).usedrange.columns.count

Peux tu expliquer vaguement ce que tu veux ? car les deux fonctions font bcp de lignes , pour peux de choses et je suis pas sur d'avoir tout compris.

Enfaite globalement je ne cherche juste pas la dernière ligne, ce code me permet de rassembler plusieurs feuilles excel en fonctions de colonnes précise de chaques feuilles, je n'ai pas mis le code en entier car ça ne concerne pas le problème. Ici enfaite je me concentre sur
Code:

1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 Set CopyRng = sh.Range("C:C") 'Test if there enough rows in the DestSh to copy all the data If Last + CopyRng.Rows.Count > DestSh.Rows.Count Then MsgBox "There are not enough rows in the Destsh" GoTo ExitTheSub End If 'This example copies values/formats and Column width CopyRng.Copy With DestSh.Cells(1, Last + 1) .PasteSpecial 8 .PasteSpecial xlPasteValues .PasteSpecial xlPasteFormats Application.CutCopyMode = False End With DestSh.Cells(Last + 1, "D").Value = sh.Name 'Resize(CopyRng.Rows.Count).
Car je veux des colonnes précise dans chaques feuilles et le usedrange prend certe la fin de chaque colonne mais prend également les autres colonnes,
et avec mon code présent j'arrive à prendre les colonnes que je veux mais la dernière ligne

Code:

DestSh.Cells(Last + 1, "D").Value = sh.Name 'Resize(CopyRng.Rows.Count).

Permet de mettre dans la colonne D la source sauf qu'elle la copie jusqu'a la fin soit 1M de liges donc je ne peux pas copier les autres sources.
En espérant avoir été assez clair !
Merci de votre réponse !

08/06/2015, 11h05
joe.levrai

Bonjour,

sans utiliser tes procédure LastRow et LastColumn

ici, on calcule la dernière ligne de la colonne A

Code:

Last = DestSh.Cells(DestSh.Rows.Count, 1).End(xlUp).Row

pour chercher la dernière ligne d'une autre colonne, tu modifies le chiffre 1 pour mettre le numéro de colonne voulue
08/06/2015, 12h36
ugovba

Bonjour,

J'ai esseyé en remplaçant les deux fonctions, cela fonctionne effectivement pour copier les données,
mais cela ne fonctionne pas pour copier le nom de la source dans une colonne.

Code:

DestSh.Cells(Last + 1, "D").Resize(CopyRng.Rows.Count).Value = sh.Name

Enfaite le problème viens du resize, si j'enlève le resize et laisse

Code:

DestSh.Cells(Last + 1, "D).Value = sh.Name

,
cela ne me la met que sur une ligne et non toute la colonne correspondant aux données copiées ! En changeant par la fonction donnée ci dessus par Joe cela me met erreur 1004 à cette ligne "Erreur définie par l'application ou l'objet".(mon code de départ copie le nom de la source sur 1M de lignes et non le nb de lignes de la source)
En espérant être toujours clair !
Merci d'avance !
10/06/2015, 17h51
joe.levrai

bonjour,

je ne sais pas où ça commence et où ça termine

en partant de ce qui marche sur une ligne

Code:

DestSh.Cells(Last + 1, "D).Value = sh.Name

il suffit de créer une plage de données qui commence par DestSh.Cells(Last + 1, "D) (si c'est la première) et la dernière ligne où faire la copie

un exemple pour comprendre, la copie se fait sur 50 lignes

Code:

Range(DestSh.Cells(Last + 1, "D"),DestSh.Cells(Last + 50, "D")).Value = sh.Name

tu n'as plus qu'à adapter, pour que le "50" se calcule automatiquement, c'est peut être déjà calculé dans ta procédure d'ailleurs, mais je n'ai pas trop le temps de décortiquer tout le fonctionnement
11/06/2015, 11h14
ugovba

Je me suis compliqué la vie avec mon code, je vais le recommencer ça sera plus simple.
Merci quand même !