XL 2013 ajouter une colonne avec le nom de la feuille d'origine

spier

XLDnaute Nouveau
Bonjour,

j'ai un code de copie qui fonctionne très bien, mais je voudrais ajouter le nom de la feuille d'origine dans la colonne o sur ma feuille "copie".

Sub COPIE_LES_LIGNES()
With Sheets("APPEL MEDICAL")
Set tbl = ActiveCell.CurrentRegion
tbl.Offset(1, 0).Resize(tbl.Rows.Count - 1, _
tbl.Columns.Count).Copy
End With
With Sheets("COPIE")
.[B1].CurrentRegion.Insert Shift:=xlDown
Application.CutCopyMode = False
End With
End Sub

Auriez-vous une idée de code que je puisse insérer?
 
Solution
bonjour,

j'ai trouvé une solution qui ne fait pas de copies parasites.
voici le code:
VB:
Sub COPIE_AM()

 Sheets("APPEL MEDICAL").Select
    Set tbl = ActiveCell.CurrentRegion
tbl.Offset(1, 0).Resize(tbl.Rows.Count - 1, _
tbl.Columns.Count).EntireRow.Select
    Selection.Copy
    Sheets("COPIE").Select
    Rows("1:1").Select
    Selection.Insert Shift:=xlDown
   
    Application.CutCopyMode = False
   
  With Sheets("COPIE").range("o1")
        .Value = "appel Médical"
        .Font.Color = -65536
        .Font.Bold = False
        .Font.Size = 8
        .Font.Name = "Comic Sans MS"
        .HorizontalAlignment = xlCenter
 
     With Sheets("COPIE").range("q1")
        .Formula = "= month(D1)"
        .Font.Color = -16777216...

Wayki

XLDnaute Impliqué
Bonjour,
On sait que la feuille d'origine s'appelle "APPEL MEDICAL" du coup :
Sub COPIE_LES_LIGNES()
With Sheets("APPEL MEDICAL")
Set tbl = ActiveCell.CurrentRegion
tbl.Offset(1, 0).Resize(tbl.Rows.Count - 1, _
tbl.Columns.Count).Copy
End With
With Sheets("COPIE")
.[B1].CurrentRegion.Insert Shift:=xlDown
Application.CutCopyMode = False
.Range("O1") = "APPEL MEDICAL"
End With
End Sub
Après sans fichier compliqué d'apporter une solution concrète.
A +
 

spier

XLDnaute Nouveau
Bonjour,
Je te remercie pour ton aide mais je n'ai pas trouvé de solution avec Ubound.
J'ai finalement opté pour me contenter d'avoir les infos sur la première ligne et utilisé entirerow pour me sortir du décalage.
Mais je rencontre un autre problème.

VB:
With Sheets("APPEL MEDICAL")
Set tbl = ActiveCell.CurrentRegion
tbl.Offset(1, 0).Resize(tbl.Rows.Count - 1, _
 tbl.Columns.Count).EntireRow.Select
 Selection.Copy
   End With
With Sheets("Feuil1")
    Selection.Insert Shift:=xlDown
Application.CutCopyMode = False
.range("o1") = "Appel Medical"
 End With
 With Sheets("Feuil1").range("o1")
        .Font.Color = -65536
        .Font.Bold = False
        .Font.Size = 8
        .Font.Name = "Comic Sans MS"
        Application.CutCopyMode = False
    'Fin de l'instruction avec : End With
    End With
     With Sheets("Feuil1").range("q1")
        .Formula = "= month(D1)"
        .Font.Color = -16777216
        .HorizontalAlignment = xlCenter
        .Font.Bold = True
        .Font.Size = 8
        .Font.Name = "Comic Sans MS"
        Application.CutCopyMode = False
        End With
         With Sheets("Feuil1").range("p1")
        .Formula = "= year(D1)"
        .Font.Color = -16777216
        .HorizontalAlignment = xlCenter
        .Font.Bold = True
        .Font.Size = 8
        .Font.Name = "Comic Sans MS"
        .NumberFormat = "General"
        Application.CutCopyMode = False
    End With
 End Sub

Au bout de trois clics sur mon bouton ça rajoute des lignes à ma copie.
Pour tester, mon tableau n'a qu'une seule ligne.

CATH
11-août​
11-août​
AOÛT0,00026,7805,3632,14IDE2400BLOC OPERATOIREServicesHAppel Medical20228
CATH
11-août​
11-août​
AOÛT0,00026,7805,3632,14IDE2400BLOC OPERATOIREServicesH
CATH
11-août​
11-août​
AOÛT0,00026,7805,3632,14IDE2400BLOC OPERATOIREServicesH
CATH
11-août​
11-août​
AOÛT0,00026,7805,3632,14IDE2400BLOC OPERATOIREServicesH
CATH
11-août​
11-août​
AOÛT0,00026,7805,3632,14IDE2400BLOC OPERATOIREServicesHAppel Medical20228
CATH
11-août​
11-août​
AOÛT0,00026,7805,3632,14IDE2400BLOC OPERATOIREServicesH
CATH
11-août​
11-août​
AOÛT0,00026,7805,3632,14IDE2400BLOC OPERATOIREServicesHAppel Medical20228
CATH
11-août​
11-août​
AOÛT0,00026,7805,3632,14IDE2400BLOC OPERATOIREServicesHAppel Medical20228

Je ne trouve pas de solution, j'ai cherché par rapport au presse papier, mais pas de changement.

Si quelqu'un à une idée, je suis preneuse.
A+
 

spier

XLDnaute Nouveau
bonjour,

j'ai trouvé une solution qui ne fait pas de copies parasites.
voici le code:
VB:
Sub COPIE_AM()

 Sheets("APPEL MEDICAL").Select
    Set tbl = ActiveCell.CurrentRegion
tbl.Offset(1, 0).Resize(tbl.Rows.Count - 1, _
tbl.Columns.Count).EntireRow.Select
    Selection.Copy
    Sheets("COPIE").Select
    Rows("1:1").Select
    Selection.Insert Shift:=xlDown
   
    Application.CutCopyMode = False
   
  With Sheets("COPIE").range("o1")
        .Value = "appel Médical"
        .Font.Color = -65536
        .Font.Bold = False
        .Font.Size = 8
        .Font.Name = "Comic Sans MS"
        .HorizontalAlignment = xlCenter
 
     With Sheets("COPIE").range("q1")
        .Formula = "= month(D1)"
        .Font.Color = -16777216
        .HorizontalAlignment = xlCenter
        .Font.Bold = True
        .Font.Size = 8
        .Font.Name = "Comic Sans MS"
       
       
         With Sheets("COPIE").range("p1")
        .Formula = "= year(D1)"
        .Font.Color = -16777216
        .HorizontalAlignment = xlCenter
        .Font.Bold = True
        .Font.Size = 8
        .Font.Name = "Comic Sans MS"
        .NumberFormat = "General"
       
    End With
    End With
     End With
      Sheets("APPEL MEDICAL").Select
    range("C11").Select
   
End Sub

merci
bonne soirée.
 

Wayki

XLDnaute Impliqué
Bonsoir,
Je répond tard mais je n'avais pas le temps de me pencher sur votre problème.
J'ai une solution mais qui ne traite pas la mise en forme, seulement les données.
La voici :
VB:
Option Base 1
Sub COPIE_LES_LIGNES()
Dim a()
a = ActiveCell.CurrentRegion
ReDim Preserve a(ActiveCell.CurrentRegion.Rows.Count, ActiveCell.CurrentRegion.Columns.Count + 1)
For i = 2 To UBound(a, 1)
    a(i, UBound(a, 2)) = "APPEL MEDICAL"
Next i
Sheets("copie").range("B1").Resize(UBound(a, 1), UBound(a, 2)) = a
End Sub
A +
 

Discussions similaires