[VBA] Fusionner plusieurs colonnes en une seule

Version imprimable

17/01/2006, 22h52
brutos2

[VBA] Fusionner plusieurs colonnes en une seule

Bonjour,

Voilà mon soucis

J'ai 6 colonnes qui peuvent être de longueurs différentes et comporter des cellules vides et à partir de ces 6 colonnes en faire une seule qui reprendrait les infos des 6

En gros mettre les colonnes à la suite les unes des autres et idéalement supprimer les cellules vides (pour cette dernière action j'ai trouver une macro sur le forum)

Merci d'avance à tous
18/01/2006, 07h20
bidou

quel version d'Excel ?
18/01/2006, 08h41
brutos2

ma version d'excel est la 2002
18/01/2006, 08h43
jmfmarques

Si ta version te permet de faire ces opérations manuellement, elles peuvent également être effectuées par du code.

Vois ce que je viens d'écrire, il y a quelques instants, à Ogenki (2ème page) à propos du sujet :
http://www.developpez.net/forums/viewtopic.php?t=443797

en ce qui concerne l'utilisation de l'enregistreur de macros.

Tu y trouveras un peu de bonheur...

:D
18/01/2006, 09h35
brutos2

Merci pour le truc ... avec ceci j'ai réussi plus ou moins à résoudre mon problème

J'arrive bien à compiler mes 6 colonnes en une seule et y ajouter un entete (je fais un tableau dynamique croisé sur la colonne créée) ...

Sauf que cela bugge si j'ai une cellule vide comme première cellule de mes colonnes ...
18/01/2006, 10h20
bidou

avec quel 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
Sub Macro4()
 
'Positionnement sur la feuille Base et copie des 6 colonnes
    Sheets("Base").Select
    Columns("F:K").Select
    Selection.Copy
 
    Range("DT1").Select
    ActiveSheet.Paste
    Range("DT5:DY6").Select
    Application.CutCopyMode = False
    Selection.Delete Shift:=xlToLeft
 
'Faire une seule colonne avec les 6 de départ
    Range("DT7:DT" & [DT65536].End(xlUp).Row).Select
    Selection.Copy
    Range("DU65536").End(xlUp).Offset(1, 0).Select
    ActiveSheet.Paste
 
    Range("DU7:DU" & [DU65536].End(xlUp).Row).Select
    Selection.Copy
    Range("DV65536").End(xlUp).Offset(1, 0).Select
    ActiveSheet.Paste
 
    Range("DV7:DV" & [DV65536].End(xlUp).Row).Select
    Selection.Copy
    Range("DW65536").End(xlUp).Offset(1, 0).Select
    ActiveSheet.Paste
 
    Range("DW7:DW" & [DW65536].End(xlUp).Row).Select
    Selection.Copy
    Range("DX65536").End(xlUp).Offset(1, 0).Select
    ActiveSheet.Paste
 
    Range("DX7:DX" & [DX65536].End(xlUp).Row).Select
    Selection.Copy
    Range("DY65536").End(xlUp).Offset(1, 0).Select
    ActiveSheet.Paste
 
    Columns("DQ:DX").Select
    Selection.Delete Shift:=xlToLeft
 
'Ecriture du titre de colonne pour pouvoir calculer un tableau dynamique dessus
    Range("DQ6").Select
    With Selection.Interior
        .ColorIndex = 34
        .Pattern = xlSolid
        .PatternColorIndex = xlAutomatic
    End With
    With Selection
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlBottom
        .WrapText = False
        .Orientation = 0
        .AddIndent = False
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = False
    End With
    ActiveCell.FormulaR1C1 = "Patho"
    With ActiveCell.Characters(Start:=1, Length:=5).Font
        .Name = "Arial"
        .FontStyle = "Gras"
        .Size = 10
        .Strikethrough = False
        .Superscript = False
        .Subscript = False
        .OutlineFont = False
        .Shadow = False
        .Underline = xlUnderlineStyleNone
        .ColorIndex = xlAutomatic
    End With
    Range("B7").Select
 
 
End Sub

18/01/2006, 13h42
jmfmarques

Le problème est peut être gébéré par l'exécution de cette ligne :

Code:

With ActiveCell.Characters(Start:=1, Length:=5).Font

qui devrait semble-t-il être précédée d'une condition (si la cellule est vide)

:idea:

pour tout remonter en première colonne j'aurais plutôt employé un code du type

Code:

1
2
3
4
5
6
7
8
9
10
11
Dim MaPlage As Range, cmpt As Long
 
Set MaPlage = Columns("A:F").SpecialCells(xlCellTypeBlanks)
'vire les cellules vides
MaPlage.Delete xlUp
'remonte toute les valeurs sur la première colonne
Set MaPlage = Columns("A:A")
For cmpt = 1 To 5
    MaPlage.Offset(, cmpt).SpecialCells(xlCellTypeConstants).Copy Destination:=MaPlage.End(xlDown).Offset(1)
Next
Columns("B:F").ClearContents