Ajout de colonne par VBA

**grenoble87** · 15/01/2014, 11h02

Bonjour à tous!
Étant débutant en VBA,, j'aimerai un peu d'aide pour la problématique suivante (Fichier en pièce jointe):
- J'aimerai créer un bouton + et un bouton - me permettant d'ajouter une colonne identique a la colonne N.
En gros actuellement sur la colonne N : Vibrations Max (mm/s) et si appui sur + , je veux créer une colonne a la suite avec Vibrations 2 Max (mm/s) jusqu'à Vibrations 4 Max (mm/s) (4 colonne de vibrations au maximum.
- Avec le bouton - , j'aimerai enlever les colonnes "Vibrations" sauf la première qui doit tout le temps être présente.

Je ne sais pas si j'ai été clair mais le fichier complétera mon explication.
Résumé:
-Au minimum une colonne vibrations (impossible d'effacer la colonne F initiale).
-Au maximum 4 colonnes vibration
-Quand création d'une nouvelle colonne il faut incrémenter exemple: Vibrations Max (mm/s) Vibrations 2 Max (mm/s) etc jusqu'à Vibrations 4 Max (mm/s)
- Les deux boutons ne doivent pas être sur la colonne F car si appui sur "+", cela va dupliqué les boutons..

Merci d'avance!

**defluc** · 15/01/2014, 12h27

Bonjour à toi,

Tout d'abord un éclaircissement : Je vois une colonne M Vibration et non N. De plus, plus loin, c'est la colonne V qui est évoquée ?

Pour le reste et pour éviter que le bouton ne soit recopié, j'ajouterais un bouton avec la mention "Ajouter une colonne vibration".

Cordialement

**grenoble87** · 15/01/2014, 13h28

Bonjour et merci pour cette réponse.

Il s'agit de la colonne M désolé pour ces fautes de frappes...

**defluc** · 15/01/2014, 16h42

Tu trouveras ci-après le code revu avec ajout des procédures AddVibrationCol et DelVibrationCol à associer aux boutons d'ajout et de suppressions de colonnes.

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
Option Explicit
Private Sub retour_menu()
Sheets("DONNEES").Select
End Sub
Private Sub ACCES_DE()
Sheets("COURBE DE").Select
End Sub
Private Sub ACCES_DB()
Sheets("COURBE DB").Select
End Sub
Private Sub ACCES_DH()
Sheets("COURBE DH").Select
End Sub
Private Sub pdf()
Dim Fsource As Workbook
Dim Rep As Byte
  Rep = MsgBox("Vous confirmez la création du fichier sous format PDF dans le répertoire C:\TEMP ? ", vbExclamation + vbOKCancel, "Confirmation création fichier")
  If Rep = vbCancel Then Exit Sub
  If Rep = vbOK Then
  End If
  Set Fsource = ThisWorkbook
  Application.DisplayAlerts = True
  Fsource.Sheets("DONNEES").ExportAsFixedFormat Type:=xlTypePDF, Filename:="c:\TEMP\TRANSITOIRES.pdf"
  Application.DisplayAlerts = False
  Set Fsource = Nothing
End Sub
Private Sub IMPRIMER_CLASSEUR()   ' IMPRIMER_CLASSEUR Macro
Dim Rep As Byte
  Rep = MsgBox("Confirmez-vous l'impression du document? ", vbExclamation + vbOKCancel, "Message alerte")
  If Rep = vbCancel Then Exit Sub
    ActiveWindow.SelectedSheets.PrintOut Copies:=1
    Sheets("COURBE DE").Select
    ActiveWindow.SelectedSheets.PrintOut Copies:=1
    Sheets("COURBE DB").Select
    ActiveWindow.SelectedSheets.PrintOut Copies:=1
    Sheets("COURBE DH").Select
    ActiveWindow.SelectedSheets.PrintOut Copies:=1
End Sub
Private Sub TEMP()
Shell "explorer C:\TEMP", vbNormalFocus
End Sub
Private Sub AddVibrationCol()
Dim LastCol As Integer, Idx As Integer
  LastCol = ThisWorkbook.Sheets(1).Range("A20").CurrentRegion.Columns.Count
  If LastCol > 15 Then Exit Sub
  ThisWorkbook.Sheets(1).Columns(13).Copy _
  Destination:=ThisWorkbook.Sheets(1).Cells(1, LastCol + 1)
  Idx = LastCol + 2 - 13
  ThisWorkbook.Sheets(1).Cells(20, LastCol + 1) = "Vibrations " & Idx & " Max (mm/s)"
End Sub
Private Sub DelVibrationCol()
Dim LastCol As Integer, Idx As Integer
  LastCol = ThisWorkbook.Sheets(1).Range("A20").CurrentRegion.Columns.Count
 
  If LastCol = 13 Then Exit Sub
  ThisWorkbook.Sheets(1).Columns(LastCol).Delete
End Sub

**grenoble87** · 15/01/2014, 17h02

Re-bonjour,

Merci beaucoup, le code fonctionne parfaitement. Pour être un peu pointilleux

Est il possible de conserver la mise en page? :
- Les bordures qui se replacent automatiquement
- La zone d'impression qui s’élargit et qui prend en compte les nouvelles colonne en compte?

Cordialement

**defluc** · 15/01/2014, 17h24

Bien sûr,
Il suffit d'ajouter le code ad hoc.
Élargissement des cellules fusionnées à la valeur de LastCol;
Remplacement de la ligne de cadre de l'avant dernière colonne par une ligne d'épaisseur moindre;
Tracé de la ligne de cadre d'épaisseur voulue à droite de la plage limitée par LastCol.

Tu devrais t'en tirer en faisant ces opérations sous l'enregistreur de macro et en adaptant le code dans les procédures AddVibrationCol et DelVibrationCol

**grenoble87** · 16/01/2014, 08h22

Bonjour,

Heu..Après quelques tentatives, j'avoue que je ne m'en sort pas vraiment, la mise en page fonctionne pour la première colonne ajouter mais ensuite c'est du grand n'importe quoi

Help....

Cordialement

**defluc** · 16/01/2014, 10h59

Voici le code modifié ou complété

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
Private Sub AddVibrationCol()
Dim LastCol As Integer, Idx As Integer
Dim TmpStr As String
  LastCol = ThisWorkbook.Sheets(1).Range("A20").CurrentRegion.Columns.Count
  If LastCol > 15 Then Exit Sub
  ThisWorkbook.Sheets(1).Columns(13).Copy _
  Destination:=ThisWorkbook.Sheets(1).Cells(1, LastCol + 1)
  Idx = LastCol + 2 - 13
  TmpStr = "Vibrations " & Idx & " Max (mm/s)"
  ThisWorkbook.Sheets(1).Cells(20, LastCol + 1) = TmpStr
  ThisWorkbook.Sheets(1).Cells(27, LastCol + 1) = TmpStr
  ThisWorkbook.Sheets(1).Cells(34, LastCol + 1) = TmpStr
  AdaptAll
End Sub
Private Sub DelVibrationCol()
Dim LastCol As Integer, Idx As Integer
  LastCol = ThisWorkbook.Sheets(1).Range("A20").CurrentRegion.Columns.Count
  If LastCol = 13 Then Exit Sub
  ThisWorkbook.Sheets(1).Columns(LastCol).Delete
  AdaptAll
End Sub
Private Sub AdaptAll()
Dim LastCol As Integer
Dim Plage As Range
Dim Sh As Worksheet
  Set Sh = ThisWorkbook.Sheets(1)
  LastCol = ThisWorkbook.Sheets(1).Range("A20").CurrentRegion.Columns.Count
  Set Plage = Sh.Range(Sh.Cells(4, 1), Sh.Cells(5, LastCol))
  Plage.MergeCells = True  '  Elargissement des cellules fusionnée de la ligne 26
  Set Plage = Sh.Range(Sh.Cells(19, 1), Sh.Cells(19, LastCol))
  Plage.MergeCells = True  '  Elargissement des cellules fusionnée de la ligne 19
  Set Plage = Sh.Range(Sh.Cells(26, 1), Sh.Cells(26, LastCol))
  Plage.MergeCells = True  '  Elargissement des cellules fusionnée de la ligne 26
  Set Plage = Sh.Range(Sh.Cells(33, 1), Sh.Cells(33, LastCol))
  Plage.MergeCells = True  '  Elargissement des cellules fusionnée de la ligne 33
  Set Plage = Sh.Range(Sh.Cells(1, LastCol), Sh.Cells(38, LastCol))
  Plage.Borders(xlEdgeLeft).Weight = xlThin     '  modification des bordures
  Plage.Borders(xlEdgeRight).Weight = xlMedium  '  de la dernière colonne
  Set Sh = Nothing
  Set Plage = Nothing
End Sub

**grenoble87** · 16/01/2014, 13h21

Bonjour,

Merci pour cette nouvelle version par contre j'ai l'impression de ne pas avoir fait le choses correctement.... Je vous joint le fichier avec les deux boutons créé...
J'ai seulement ajouter les lignes de codes a la suite mais ca ne se passe pas comme prévu...

Ajout de colonne par VBA

Macros et VBA Excel

Vue hybride

Discussions similaires

Partager

Partager