je pense qu'il est pr=E9f=E9rable de mettre en lien le fichier original
qui me servira par la suite de base de donn=E9es
afin que vous puissiez mieux voir les erreurs que je fais certainement
ci joint mon fichier :
http://cjoint.com/?fxr3waD08e
Cette action est irreversible, confirmez la suppression du commentaire ?
Signaler le commentaire
Veuillez sélectionner un problème
Nudité
Violence
Harcèlement
Fraude
Vente illégale
Discours haineux
Terrorisme
Autre
FFO
Bonsoir sdellaux Surtout ne pas perdre espoire !!!!! Méa culpa !!!!! Effectivement dans l'obtique de colonnes rajoutées ou supprimées (il y a dans ce fichier onglet "BDG" 1 colonne en moins , colonne M, par rapport aux différents fichiers précédent) j'ai modifié le code en pensant avoir corrigé toutes les lignes concernées Que Nenni cette ligne était passée à la trape Celà m'apprendra à ne pas tester !!! Cette dernière ligne adaptée j'ai procédé à un ultime test avec succés et ce avec ce dernier fichier Ca fonctionne avec ce code :
Private Sub WorkSheet_BeforeDoubleClick(ByVal Target As Range, Cancel As _ Boolean) Cancel = True If ActiveCell.Address = Range("H1").Address Then Sheets.Add Nom = ActiveSheet.Name Sheets(Nom).Range("B1").EntireRow.Value = _ Sheets("BDG").Range("B2").EntireRow.Value Sheets("BDG").Range("IV1").End(xlToLeft).Value = "CREER" & " " & Nom End If If ActiveCell.Address = Range("IV1").End(xlToLeft).Address Then Columns("C:C").Select 'Selection.TextToColumns Destination:=Range("C1"), DataType:=xlDelimited, _ 'TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:úlse, _ 'Tab:=True, _ 'Semicolon:úlse, Comma:úlse, Space:úlse, Other:úlse, _ 'FieldInfo _ ':=Array(1, 1), TrailingMinusNumbers:=True Onglet = Mid(Range("IV1").End(xlToLeft), 7, Len(Range("IV1").End(xlToLeft)) - 6) For I = 1 To Sheets.Count If Sheets(I).Name = Onglet Then ligne = Sheets(Onglet).Range("B65535").End(xlUp).Row Sheets(Onglet).Range("A" & ligne).EntireRow.Copy Range("B65535").End(xlUp).Offset(1, -1).Select ActiveSheet.Paste ActiveCell.Offset(-1, 0).EntireRow.Copy Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _ SkipBlanks:úlse, Transpose:úlse Range([B65535].End(xlUp).Offset(0, -1), [A3]).EntireRow.Select Selection.Sort Key1:=Range("C3"), Order1:=xlAscending, Header:=xlNo, _ OrderCustom:=1, MatchCase:úlse, Orientation:=xlTopToBottom, _ DataOption1:=xlSortNormal End If Next Application.DisplayAlerts = False Sheets(Onglet).Select ActiveWindow.SelectedSheets.Delete End If End Sub
J'espère enfin que chez toi aussi !!! Donnes moi la bonne nouvelle !!! Dis moi ce que tu compte faire pourl'ajout des colonnes La solution manuelle est elle celle que tu as retenu ???
Dans l'attente de te lire
rebonjour j'ai donc repris en copier coller le code après premier essais j'ai erreur signalée a cette ligne
je pense qu'il est préférable de mettre en lien le fichier original qui me servira par la suite de base de données afin que vous puissiez mieux voir les erreurs que je fais certainement
ci joint mon fichier : http://cjoint.com/?fxr3waD08e
cordialement stéphane
Bonsoir sdellaux
Surtout ne pas perdre espoire !!!!!
Méa culpa !!!!!
Effectivement dans l'obtique de colonnes rajoutées ou supprimées (il y a
dans ce fichier onglet "BDG" 1 colonne en moins , colonne M, par rapport aux
différents fichiers précédent)
j'ai modifié le code en pensant avoir corrigé toutes les lignes concernées
Que Nenni cette ligne était passée à la trape
Celà m'apprendra à ne pas tester !!!
Cette dernière ligne adaptée j'ai procédé à un ultime test avec succés et ce
avec ce dernier fichier
Ca fonctionne avec ce code :
Private Sub WorkSheet_BeforeDoubleClick(ByVal Target As Range, Cancel As _
Boolean)
Cancel = True
If ActiveCell.Address = Range("H1").Address Then
Sheets.Add
Nom = ActiveSheet.Name
Sheets(Nom).Range("B1").EntireRow.Value = _
Sheets("BDG").Range("B2").EntireRow.Value
Sheets("BDG").Range("IV1").End(xlToLeft).Value = "CREER" & " " & Nom
End If
If ActiveCell.Address = Range("IV1").End(xlToLeft).Address Then
Columns("C:C").Select
'Selection.TextToColumns Destination:=Range("C1"), DataType:=xlDelimited, _
'TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:úlse, _
'Tab:=True, _
'Semicolon:úlse, Comma:úlse, Space:úlse, Other:úlse, _
'FieldInfo _
':=Array(1, 1), TrailingMinusNumbers:=True
Onglet = Mid(Range("IV1").End(xlToLeft), 7, Len(Range("IV1").End(xlToLeft))
- 6)
For I = 1 To Sheets.Count
If Sheets(I).Name = Onglet Then
ligne = Sheets(Onglet).Range("B65535").End(xlUp).Row
Sheets(Onglet).Range("A" & ligne).EntireRow.Copy
Range("B65535").End(xlUp).Offset(1, -1).Select
ActiveSheet.Paste
ActiveCell.Offset(-1, 0).EntireRow.Copy
Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
SkipBlanks:úlse, Transpose:úlse
Range([B65535].End(xlUp).Offset(0, -1), [A3]).EntireRow.Select
Selection.Sort Key1:=Range("C3"), Order1:=xlAscending, Header:=xlNo, _
OrderCustom:=1, MatchCase:úlse, Orientation:=xlTopToBottom, _
DataOption1:=xlSortNormal
End If
Next
Application.DisplayAlerts = False
Sheets(Onglet).Select
ActiveWindow.SelectedSheets.Delete
End If
End Sub
J'espère enfin que chez toi aussi !!!
Donnes moi la bonne nouvelle !!!
Dis moi ce que tu compte faire pourl'ajout des colonnes
La solution manuelle est elle celle que tu as retenu ???
Dans l'attente de te lire
rebonjour
j'ai donc repris en copier coller le code
après premier essais
j'ai erreur signalée a cette ligne
je pense qu'il est préférable de mettre en lien le fichier original
qui me servira par la suite de base de données
afin que vous puissiez mieux voir les erreurs que je fais certainement
ci joint mon fichier :
http://cjoint.com/?fxr3waD08e
Bonsoir sdellaux Surtout ne pas perdre espoire !!!!! Méa culpa !!!!! Effectivement dans l'obtique de colonnes rajoutées ou supprimées (il y a dans ce fichier onglet "BDG" 1 colonne en moins , colonne M, par rapport aux différents fichiers précédent) j'ai modifié le code en pensant avoir corrigé toutes les lignes concernées Que Nenni cette ligne était passée à la trape Celà m'apprendra à ne pas tester !!! Cette dernière ligne adaptée j'ai procédé à un ultime test avec succés et ce avec ce dernier fichier Ca fonctionne avec ce code :
Private Sub WorkSheet_BeforeDoubleClick(ByVal Target As Range, Cancel As _ Boolean) Cancel = True If ActiveCell.Address = Range("H1").Address Then Sheets.Add Nom = ActiveSheet.Name Sheets(Nom).Range("B1").EntireRow.Value = _ Sheets("BDG").Range("B2").EntireRow.Value Sheets("BDG").Range("IV1").End(xlToLeft).Value = "CREER" & " " & Nom End If If ActiveCell.Address = Range("IV1").End(xlToLeft).Address Then Columns("C:C").Select 'Selection.TextToColumns Destination:=Range("C1"), DataType:=xlDelimited, _ 'TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:úlse, _ 'Tab:=True, _ 'Semicolon:úlse, Comma:úlse, Space:úlse, Other:úlse, _ 'FieldInfo _ ':=Array(1, 1), TrailingMinusNumbers:=True Onglet = Mid(Range("IV1").End(xlToLeft), 7, Len(Range("IV1").End(xlToLeft)) - 6) For I = 1 To Sheets.Count If Sheets(I).Name = Onglet Then ligne = Sheets(Onglet).Range("B65535").End(xlUp).Row Sheets(Onglet).Range("A" & ligne).EntireRow.Copy Range("B65535").End(xlUp).Offset(1, -1).Select ActiveSheet.Paste ActiveCell.Offset(-1, 0).EntireRow.Copy Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _ SkipBlanks:úlse, Transpose:úlse Range([B65535].End(xlUp).Offset(0, -1), [A3]).EntireRow.Select Selection.Sort Key1:=Range("C3"), Order1:=xlAscending, Header:=xlNo, _ OrderCustom:=1, MatchCase:úlse, Orientation:=xlTopToBottom, _ DataOption1:=xlSortNormal End If Next Application.DisplayAlerts = False Sheets(Onglet).Select ActiveWindow.SelectedSheets.Delete End If End Sub
J'espère enfin que chez toi aussi !!! Donnes moi la bonne nouvelle !!! Dis moi ce que tu compte faire pourl'ajout des colonnes La solution manuelle est elle celle que tu as retenu ???
Dans l'attente de te lire
rebonjour j'ai donc repris en copier coller le code après premier essais j'ai erreur signalée a cette ligne
je pense qu'il est préférable de mettre en lien le fichier original qui me servira par la suite de base de données afin que vous puissiez mieux voir les erreurs que je fais certainement
ci joint mon fichier : http://cjoint.com/?fxr3waD08e