Ajout de colonne par VBA

Version imprimable

15/01/2014, 11h02
grenoble87

1 pièce(s) jointe(s)

Ajout de colonne par VBA

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!
15/01/2014, 12h27
defluc

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
15/01/2014, 13h28
grenoble87

Bonjour et merci pour cette réponse.

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

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:

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

15/01/2014, 17h02
grenoble87

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
15/01/2014, 17h24
defluc

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
16/01/2014, 08h22
grenoble87

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

Voici le code modifié ou complété

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
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

16/01/2014, 13h21
grenoble87

1 pièce(s) jointe(s)

RE

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...
16/01/2014, 15h45
defluc

Chez moi, cela fonctionne impeccablement.