XL 2016 Envoie et enregistrer uniquement le contenu tableau

[SETILA]

Hello à tous,

Pouvez-m'aider afin que lors de l'envoi de mon fichier, celui ci enregistre et envoi uniquement le tableau complété et non toutes les cellules vides.

Private Sub CommandButton1_Click()
Dim Fichier As String
Dim Sh As Variant
Dim cp As Variant
Fichier = "C:\Users\ABENMOUSSA\Desktop\CA PANDORA.pdf" 'à adapter

Set Sh = ActiveSheet
Application.ScreenUpdating = False

Sh.ExportAsFixedFormat Type:=xlTypePDF, _
Filename:=Fichier, _
Quality:=xlQualityStandard, _
IncludeDocProperties:=True, _
IgnorePrintAreas:=False, _
OpenAfterPublish:=False

Sheets.Add After:=Sheets(Sheets.Count)

ActiveWorkbook.EnvelopeVisible = True
With ActiveSheet.MailEnvelope
For cp = .Item.Attachments.Count To 1 Step -1
.Item.Attachments(cp).Delete
Next cp
.Item.To = "cama@pandora.net;moam@pandora.net;MAXIME.VERFAILLIE@disney.com;ali.benmoussa@disney.com;marine.jacquemin@disney.com;OM.MARIANNIE@disney.com;MONICA.ANFOSSI@disney.com;SABINE.DUTEIL@disney.com;CARLA.COCINI@disney.com;MICHAEL.MANTEL@disney.com"
.Item.Subject = "Chiffres Pandora"
.Introduction = " Hello tout le monde," & vbCrLf & vbCrLf & "Ci-joint les chiffres Pandora" & vbCrLf & vbCrLf & "Cordialement," & vbCrLf & vbCrLf & "Team Legends"
.Item.Attachments.Add Fichier
.Item.Send
End With

Application.DisplayAlerts = False
ActiveSheet.Delete
Sh.Activate
Application.ScreenUpdating = True

End Sub

Bonne après-midi

Setila

 

[danielco]

Bonjour,

Je ne comprends pas bien. Tu veux enregistrer les 16 000 colonnes et 1 000 000 lignes de la feuille ???

Cordialement.

Daniel

 

[SETILA]

Bonjour Danielco,

Je veux que excel enregistre et envoi uniquement les lignes qui sont complétées.

Cordialement,

Setila

 

[danielco]

Le mieux serait que tu postes un classeur exemple, pour voir l'emplacement du tableau.

Daniel

 

[SETILA]

Le fichier transféré est trop volumineux.

Comment faire ?

Setila

 

[danielco]

Tu peux le charger sur https://mon-partage.fr/ si ton fichier fait moins de 200 Mo. S'il est plus gros, quelle est sa taille ?

Daniel

 

[SETILA]

Ce lien n'existe plus

Je ne comprends pas pourquoi il est aussi lourd ??? il y a que 2 onglets!

Setila

 

[danielco]

Essaie :

Private Sub CommandButton1_Click()
Dim Fichier As String
Dim Sh As Variant
Dim cp As Variant
Dim Plage As Range
Fichier = "C:\Users\ABENMOUSSA\Desktop\CA PANDORA.pdf" 'à adapter

Set Sh = ActiveSheet
Application.ScreenUpdating = False
With Sh
  Set Plage = .Range("A1", .Cells(.Rows.Count, 1).End(xlUp)).Resize(, 10)
End With
Plage.ExportAsFixedFormat Type:=xlTypePDF, _
    Filename:=Fichier, _
    Quality:=xlQualityStandard, _
    IncludeDocProperties:=True, _
    IgnorePrintAreas:=False, _
    OpenAfterPublish:=False
    
Sheets.Add After:=Sheets(Sheets.Count)

    ActiveWorkbook.EnvelopeVisible = True
    With ActiveSheet.MailEnvelope
        For cp = .Item.Attachments.Count To 1 Step -1
        .Item.Attachments(cp).Delete
        Next cp
    .Item.To = "cama@pandora.net;moam@pandora.net;MAXIME.VERFAILLIE@disney.com;ali.benmoussa@disney.com;marine.jacquemin@disney.com;OM.MARIANNIE@disney.com;MONICA.ANFOSSI@disney.com;SABINE.DUTEIL@disney.com;CARLA.COCINI@disney.com;MICHAEL.MANTEL@disney.com"
    .Item.Subject = "Chiffres Pandora"
    .Introduction = " Hello tout le monde," & vbCrLf & vbCrLf & "Ci-joint les chiffres Pandora" & vbCrLf & vbCrLf & "Cordialement," & vbCrLf & vbCrLf & "Team Legends"
    .Item.Attachments.Add Fichier
    .Item.Send
    End With

Application.DisplayAlerts = False
ActiveSheet.Delete
Sh.Activate
Application.ScreenUpdating = True

End Sub

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, cancel As Boolean)
Dim Lg As Long
Dim E As Long
Dim Code As String


  If Target.Column = 2 Then
    cancel = True
    Range("B" & Target.Row).Value = Date
'''''    If ActiveCell.Value = "" Then
'''''      ActiveCell.Value = "OK"
'''''      ActiveCell.Interior.ColorIndex = 4
'''''      Range("B" & Target.Row).Resize(1, 4).Copy
'''''      With Sheets("Com.Team Ouest")
'''''        .Range("A" & .Range("A65536").End(xlUp).Row + 1).PasteSpecial xlPasteValues
'''''      End With
'''''      Application.CutCopyMode = False
'''''    Else
'''''      ActiveCell.Value = ""
'''''      ActiveCell.Interior.ColorIndex = 2
'''''      Code = Target.Offset(0, 1) & Target.Offset(0, 2)
'''''      With Sheets("Com.Team Ouest")
'''''        Lg = .Range("A65536").End(xlUp).Row
'''''        For E = 7 To Lg
'''''          If Code = .Cells(E, "A") & .Cells(E, "B") Then
'''''            Exit For
'''''          End If
'''''        Next E
'''''        If E <= Lg Then
'''''          .Range("A" & E + 1 & ":E" & Lg + 1).Copy Destination:=.Range("A" & E)
''''''          .Range("A" & E + 1 & ":E" & Lg + 1).Copy
''''''          .Range("A" & E).PasteSpecial xlPasteValues
''''''          Application.CutCopyMode = False
'''''        End If
'''''      End With
'''''    End If
  End If
End Sub

Daniel

 

[danielco]

Ce lien n'existe plus

Je ne comprends pas pourquoi il est aussi lourd ??? il y a que 2 onglets!

Setila

Il faut supprimer les lignes superflues sur la feuille Archives RDP.

Daniel

 

[SETILA]

Hello Daniel,

je venais d'écrire ceci :

Private Sub CommandButton1_Click()
Dim Fichier As String
Dim TEXTE As String
Dim Sh As Variant
Dim cp As Variant
Dim Plage As Range
Application.ScreenUpdating = False
TEXTE = Range("J3")
TEXTE = Replace(Replace(Sheets("RDP").Range("J3").Value, "/", "."), ":", "H")
Application.ThisWorkbook.Saved = True
On Error Resume Next

Application.OnTime tps, Procedure:="GuidoNow", Schedule:=False
Set tps = Nothing
Fichier = "C:\Users\ABENMOUSSA\Desktop\Dossier\RDP " 'à adapter
'ActiveSheet.PageSetup.PrintArea = ("A1:J" & Range("A65536").End(xlUp).Row)
Set Sh = ActiveSheet
With Sh
Set Plage = .Range("A1", .Cells(.Rows.Count, 1).End(xlUp)).Resize(, 10)
End With

Sh.ExportAsFixedFormat Type:=xlTypePDF, _
Filename:=Fichier & TEXTE, _
Quality:=xlQualityStandard, _
IncludeDocProperties:=True, _
IgnorePrintAreas:=False, _
OpenAfterPublish:=False

Sheets.Add After:=Sheets(Sheets.Count)

ActiveWorkbook.EnvelopeVisible = True
With ActiveSheet.MailEnvelope
For cp = .Item.Attachments.Count To 1 Step -1
.Item.Attachments(cp).Delete
Next cp
.Item.To = "ali.benmoussa@disney.com"
.Item.Subject = "Chiffres Pandora"
.Introduction = " Hello tout le monde," & vbCrLf & vbCrLf & "Ci-joint les chiffres Pandora" & vbCrLf & vbCrLf & "Cordialement," & vbCrLf & vbCrLf & "Team Legends"
.Item.Attachments.Add Fichier
.Item.Send
End With

Application.DisplayAlerts = False
ActiveSheet.Delete
Sh.Activate
Application.ScreenUpdating = True

End Sub

ton code fonctionne très bien!

 

[SETILA]

Comment enlever les lignes superfues car j'ai supprimé mais ça fonctionne pas ?

Setila

 

[SETILA]

Hello Daniel,

Merci beaucoup pour ton aide et j'ai enfin reussi à rendre mon fichier moins lourd grace au mfc !
Bonne soirée

Setila