COPIER/COLLER dans nouveau classeur excel

Bonjour,

Bon d'accord, vous me direz que je suis un peu stupide...
Faut voir !!!!!! Vous vous creez des problemes tout seul, pourquoi avoir ouvert un deuxieme excel alors que vous etes deja sous excel ?

Pour votre copier/coller
Vous pouvez remplacer la boucle J par un resize

Bonjour,

Merci pour le "Faut voir !!" :)

J'ouvre un deuxième excel destiné à être envoyé par e-mail puis directement détruit. Le but étant d'informer un commercial sur les en-cours de ses clients et uniquement de ses clients (le fichier de base contenant tous les clients).

Voilà la la raison pour laquelle j'ai besoin d'un fichier Excel séparé. Je ne sais absolument pas ce qu'est un Resize. Quoi qu'il en soit, le fichier est fonctionnel et je me permets de le mettre ci-dessous pour peut-être aider certaines personnes :

Public Function FichierExiste(MonFichier As String)
 
   If Len(Dir(MonFichier)) > 0 Then
      FichierExiste = True
   Else
      FichierExiste = False
   End If
End Function


Sub MAIL_GAEL()

Call COLORER

Dim xlApp As Excel.Application
Dim xlBook As Excel.Workbook
Dim xlSheet As Excel.Worksheet
Dim DL As Long
Dim x As Integer
Dim Fichier_Cible As String
Dim Plage As Range
Dim NOM_ORIGINE As String
Dim Chemin As String

NOM_ORIGINE = ThisWorkbook.Name

Fichier_Cible = Workbooks(NOM_ORIGINE).Sheets("Tableau de relance").Range("W1") & "\RELANCES_GAEL.xls"

If FichierExiste(Fichier_Cible) = True Then
    Kill (Fichier_Cible)
End If

Set xlApp = CreateObject("Excel.Application")
xlApp.SheetsInNewWorkbook = 1
Set xlBook = xlApp.Workbooks.Add
xlBook.SaveAs ("RELANCES_GAEL.xls")
xlApp.Visible = True
Set xlSheet = xlBook.Worksheets(1)

Chemin = xlBook.Path

Workbooks(NOM_ORIGINE).Sheets("Tableau de relance").Range("W1") = Chemin
Workbooks(NOM_ORIGINE).Sheets("Tableau de relance").Range("W1").Font.Color = RGB(255, 255, 255)

DL = Workbooks(NOM_ORIGINE).Sheets("Tableau de relance").Cells(Application.Rows.Count, 1).End(xlUp).Row

x = 3

For i = 1 To DL

If Workbooks(NOM_ORIGINE).Sheets("Tableau de Relance").Range("A" & i).Interior.Color = RGB(196, 189, 151) Then

For J = 2 To 7

xlBook.Sheets(1).Cells(x, J) = Workbooks(NOM_ORIGINE).Sheets("Tableau de relance").Cells(i, J)

Next J

For J = 9 To 11

xlBook.Sheets(1).Cells(x, J) = Workbooks(NOM_ORIGINE).Sheets("Tableau de relance").Cells(i, J)

Next J

If Workbooks(NOM_ORIGINE).Sheets("Tableau de relance").Cells(i, 1).Value <> "" Then xlBook.Sheets(1).Cells(x, 1).Value = CDate(Workbooks(NOM_ORIGINE).Sheets("Tableau de relance").Cells(i, 1))
If Workbooks(NOM_ORIGINE).Sheets("Tableau de relance").Cells(i, 8).Value <> "" Then xlBook.Sheets(1).Cells(x, 8).Value = CDate(Workbooks(NOM_ORIGINE).Sheets("Tableau de relance").Cells(i, 8))
If Workbooks(NOM_ORIGINE).Sheets("Tableau de relance").Cells(i, 12).Value <> "" Then xlBook.Sheets(1).Cells(x, 12).Value = CDate(Workbooks(NOM_ORIGINE).Sheets("Tableau de relance").Cells(i, 12))
If Workbooks(NOM_ORIGINE).Sheets("Tableau de relance").Cells(i, 13).Value <> "" Then xlBook.Sheets(1).Cells(x, 13).Value = CDate(Workbooks(NOM_ORIGINE).Sheets("Tableau de relance").Cells(i, 13))
If Workbooks(NOM_ORIGINE).Sheets("Tableau de relance").Cells(i, 14).Value <> "" Then xlBook.Sheets(1).Cells(x, 14).Value = CDate(Workbooks(NOM_ORIGINE).Sheets("Tableau de relance").Cells(i, 14))
If Workbooks(NOM_ORIGINE).Sheets("Tableau de relance").Cells(i, 15).Value <> "" Then xlBook.Sheets(1).Cells(x, 15).Value = CDate(Workbooks(NOM_ORIGINE).Sheets("Tableau de relance").Cells(i, 15))

For J = 16 To 17

xlBook.Sheets(1).Cells(x, J) = Workbooks(NOM_ORIGINE).Sheets("Tableau de relance").Cells(i, J)

Next J

x = x + 1

End If
   
Next i

With xlBook.Sheets(1)
    .Range("A1:Q1").Merge
    .Range("A1").HorizontalAlignment = xlCenter
    .Range("A1").Value = "TABLEAU DE SUIVI DES IMPAYES (CLIENTS GAEL)"
    .Range("A1").Font.Bold = True
    .Range("A2").Value = "Date"
    .Range("B2").Value = "C.J"
    .Range("C2").Value = "Code Tiers"
    .Range("D2").Value = "N° Facture"
    .Range("E2").Value = "LIBELLE ECRITURE"
    .Range("H2").Value = "ECHEANCE"
    .Range("I2").Value = "DEBIT"
    .Range("J2").Value = "CREDIT"
    .Range("K2").Value = "SOLDE"
    .Range("L2").Value = "DATE LETTRE RAPPEL"
    .Range("M2").Value = "DATE LETTRE"
    .Range("N2").Value = "DATE MISE EN DEMEURE"
    .Range("O2").Value = "DATE POURSUITES JUDICIAIRES"
    .Range("Q2").Value = "ACTIONS"
    .Range("A2:Q2").Font.Bold = True
    .Columns("Q:Q").ColumnWidth = 90
    .Columns("I:K").NumberFormat = "#,##0.00 $"
End With
    
xlBook.Save

xlBook.Close

Set ObjOutlook = New Outlook.Application
Set oBjMail = ObjOutlook.CreateItem(olMailItem)

Nom_Fichier = Chemin & "\RELANCES_GAEL.xls"
If Nom_Fichier = "" Then Exit Sub

With oBjMail
    .To = Range("T1").Value
    .Subject = "RETARDS DE PAIEMENT SUR CLIENTS TRANSEUROPE"
    .Body = "Bonjour," & vbLf & vbLf & "Vous trouverez en PJ le fichier récapitulatif des impayés pour les clients vous concernant." & vbLf & vbLf & "Merci d'avance de faire le nécessaire." & vbLf & vbLf & "Cordialement."
    .Attachments.Add Nom_Fichier
    .Send
End With
    Set oBjMail = Nothing
    Set ObjOutlook = Nothing
    Kill Workbooks(NOM_ORIGINE).Sheets("Tableau de relance").Range("W1").Value & "\RELANCES_GAEL.xls"
    
    MsgBox ("Mail envoyé à " & Range("T1").Value & ".")
    
End Sub

Merci pour votre aide f894009.

Cordialement.

Bonjour f894009,

Merci pour la réponse.

Comment n'ouvrir qu'un fichier sans ouvrir une deuxième application excel alors?

Merci d'avance.

Cordialement.