COPIER/COLLER dans nouveau classeur excel [Résolu/Fermé]

Signaler
Messages postés
850
Date d'inscription
vendredi 13 février 2015
Statut
Membre
Dernière intervention
15 février 2019
-
Messages postés
850
Date d'inscription
vendredi 13 février 2015
Statut
Membre
Dernière intervention
15 février 2019
-
Bonjour,

J'ai actuellement codé ceci :


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


Sub AJOUTER_CLASSEUR()

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

Fichier_Cible = "K:\TEMP\RELANCES.xls"

If FichierExiste(Fichier_Cible) = True Then
    Kill ("K:\TEMP\RELANCES.xls")
End If

Set xlApp = CreateObject("Excel.Application")
xlApp.SheetsInNewWorkbook = 1
Set xlBook = xlApp.Workbooks.Add
xlBook.SaveAs ("K:\TEMP\RELANCES.xls")
xlApp.Visible = True
Set xlSheet = xlBook.Worksheets(1)


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

x = 2

For i = 1 To DL

Workbooks("Relances_CodeSTAT.xlsm").Activate

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

Workbooks("Relances_CodeSTAT.xlsm").Sheets("Tableau de Relance").Range(Cells(i, 1), Cells(i, 17)).Copy Workbooks("RELANCES.xls").Sheets(1).Range("A1")

End If
   
Next i

   
End Sub


Voilà le problème, la ligne

Workbooks("Relances_CodeSTAT.xlsm").Sheets("Tableau de Relance").Range(Cells(i, 1), Cells(i, 17)).Copy Workbooks("RELANCES.xls").Sheets(1).Range("A1")


Se met en jaune et on me dit, l'indice n'appartient pas à sélection. Depuis 1h j'essaye de copier chaque ligne de ma condition sur le nouveau fichier excel créé mais pas moyen...

Merci d'avance pour votre aide.

Cordialement.

4 réponses

Messages postés
15348
Date d'inscription
dimanche 25 novembre 2007
Statut
Membre
Dernière intervention
22 septembre 2020
1 360
Bonjour,
Dans cette ligne de code remplacez workbooks("relance......... par la variable xlsheet que vous avez définie plus haut.
Messages postés
850
Date d'inscription
vendredi 13 février 2015
Statut
Membre
Dernière intervention
15 février 2019
38
Bonjour,

Merci de votre aide.

Cette fois on a la ligne :

Workbooks(NOM_ORIGINE).Sheets("Tableau de Relance").Range(Cells(i, 1), Cells(i, 17)).Copy xlBook.Sheets(1).Range("A1")


En jaune et on me dit "La méthode Copy de la classe Range a échoué."

Même chose si je remplace xlBook par xlSheet.
Messages postés
850
Date d'inscription
vendredi 13 février 2015
Statut
Membre
Dernière intervention
15 février 2019
38
Bon, du coup j'ai fait comme ça. Je crois que le copier/coller est quelque chose que je ne maîtriserais jamais en VBA...

xlBook.Sheets(1).Range("A" & x) = Workbooks(NOM_ORIGINE).Sheets("Tableau de relance").Range("A" & i)
xlBook.Sheets(1).Range("B" & x) = Workbooks(NOM_ORIGINE).Sheets("Tableau de relance").Range("B" & i)
xlBook.Sheets(1).Range("C" & x) = Workbooks(NOM_ORIGINE).Sheets("Tableau de relance").Range("C" & i)
xlBook.Sheets(1).Range("D" & x) = Workbooks(NOM_ORIGINE).Sheets("Tableau de relance").Range("D" & i)
xlBook.Sheets(1).Range("E" & x) = Workbooks(NOM_ORIGINE).Sheets("Tableau de relance").Range("E" & i)
xlBook.Sheets(1).Range("F" & x) = Workbooks(NOM_ORIGINE).Sheets("Tableau de relance").Range("F" & i)
xlBook.Sheets(1).Range("G" & x) = Workbooks(NOM_ORIGINE).Sheets("Tableau de relance").Range("G" & i)
xlBook.Sheets(1).Range("H" & x) = Workbooks(NOM_ORIGINE).Sheets("Tableau de relance").Range("H" & i)
xlBook.Sheets(1).Range("I" & x) = Workbooks(NOM_ORIGINE).Sheets("Tableau de relance").Range("I" & i)
xlBook.Sheets(1).Range("J" & x) = Workbooks(NOM_ORIGINE).Sheets("Tableau de relance").Range("J" & i)
xlBook.Sheets(1).Range("K" & x) = Workbooks(NOM_ORIGINE).Sheets("Tableau de relance").Range("K" & i)
xlBook.Sheets(1).Range("L" & x) = Workbooks(NOM_ORIGINE).Sheets("Tableau de relance").Range("L" & i)
xlBook.Sheets(1).Range("M" & x) = Workbooks(NOM_ORIGINE).Sheets("Tableau de relance").Range("M" & i)
xlBook.Sheets(1).Range("N" & x) = Workbooks(NOM_ORIGINE).Sheets("Tableau de relance").Range("N" & i)
xlBook.Sheets(1).Range("N" & x) = Workbooks(NOM_ORIGINE).Sheets("Tableau de relance").Range("O" & i)
xlBook.Sheets(1).Range("N" & x) = Workbooks(NOM_ORIGINE).Sheets("Tableau de relance").Range("P" & i)
xlBook.Sheets(1).Range("N" & x) = Workbooks(NOM_ORIGINE).Sheets("Tableau de relance").Range("Q" & i)
Messages postés
850
Date d'inscription
vendredi 13 février 2015
Statut
Membre
Dernière intervention
15 février 2019
38
Bon d'accord, vous me direz que je suis un peu stupide... J'ai donc modifié le code ainsi :

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 = 1 To 16

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


Si vous pensez pouvoir mieux faire avec du copier/coller...

Merci en tout cas.
Messages postés
15348
Date d'inscription
dimanche 25 novembre 2007
Statut
Membre
Dernière intervention
22 septembre 2020
1 360
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
Messages postés
850
Date d'inscription
vendredi 13 février 2015
Statut
Membre
Dernière intervention
15 février 2019
38
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.
Messages postés
15348
Date d'inscription
dimanche 25 novembre 2007
Statut
Membre
Dernière intervention
22 septembre 2020
1 360 >
Messages postés
850
Date d'inscription
vendredi 13 février 2015
Statut
Membre
Dernière intervention
15 février 2019

Re,

J'ouvre un deuxième excel Non, vous ouvrez une deuxieme application EXCEL pas seulement un fichier
Messages postés
850
Date d'inscription
vendredi 13 février 2015
Statut
Membre
Dernière intervention
15 février 2019
38
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.