Question pour transfert de données

A

Angy1105

XLDnaute Junior
Bonjour le forum,

J'ai encore besoin d'un petit coupe de main.
J'ai un souci dans le transfert de mes données d'un fichier à un autre.
J'utilise le code suivant qui permet lorsqu’une case remplie une condition que les données soient transférées à l'aide d'un bouton :

PHP: 
Sub Transfert()

    Dim wk As Workbook
    Dim Plage As Range, c As Range
    Dim Lig As Long
      
 
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False

    On Error Resume Next
    Set wk = Workbooks("REPORTING.xls")
    If Err > 0 Then
        Err.Clear
        Set wk = Workbooks.Open(ThisWorkbook.Path & "\REPORTING.xls")
    End If
    ThisWorkbook.Activate
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
 
    If Err.Number > 0 Then
        MsgBox "Erreur lors de l'ouverture du fichier REPORTING.xls", vbCritical, "Exportation"
        Exit Sub
    End If

    On Error GoTo 0
        Set Plage = Sheets("Suivi").Range("I6:I300")
        For Each c In Plage
            If UCase(c.Text) = "IsDate" Then
                With wk.Sheets("Feuil1")
                    Lig = .Range("A" & .Rows.Count).End(xlUp).Row + 1
                    .Range("A" & Lig) = Sheets("Suivi").Range("A" & c.Row)
                    .Range("B" & Lig) = Sheets("Suivi").Range("B" & c.Row)
                    .Range("C" & Lig) = Sheets("Suivi").Range("C" & c.Row)
                    .Range("D" & Lig) = Sheets("Suivi").Range("D" & c.Row)
                    .Range("E" & Lig) = Sheets("Suivi").Range("G" & c.Row)
                End With
            End If
        Next c
        
  If Not wk Is Nothing Then
       wk.Save
       wk.Close
  End If
  
End Sub
Je n'ai pas d'erreur, le fichier reporting s'ouvre mais aucun transfert ne se fait!!
Je pense que l'erreur vient de la définition de la plage, la condition pour que le transfert se fasse c'est le remplissage de la colonne I avec une date.
Je vous envoie un exemple pour y voir plus clair.

Je continue de chercher, encore et encore...
Merci d'avance.

Bonne journée.
 

Pièces jointes

  • Classeur1.xls
    18 KB · Affichages: 79
  • Classeur1.xls
    18 KB · Affichages: 77
  • Classeur1.xls
    18 KB · Affichages: 77
Trier par date Trier par votes
A

Angy1105

XLDnaute Junior
Re : Question pour transfert de données

Bonjour à tous,

On a toujours l'impression que tout est ok mais lorsqu'on fait des simulations, il y a toujours un truc qui bugg...

J'ai rajouté dans la macro (ci-dessus), le transfert des mêmes données mais avec un autre critère, ce qui donne le code suivant :
Code: 
Sub Transfert()

    Dim wk As Workbook
    Dim Plage As Range, c As Range
    Dim Lig As Long
      
 
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False

    On Error Resume Next
    Set wk = Workbooks("REPORTING.xls")
    If Err > 0 Then
        Err.Clear
        Set wk = Workbooks.Open(ThisWorkbook.Path & "\REPORTING.xls")
    End If
    ThisWorkbook.Activate
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
 
    If Err.Number > 0 Then
        MsgBox "Erreur lors de l'ouverture du fichier REPORTING.xls", vbCritical, "Exportation"
        Exit Sub
    End If

    On Error GoTo 0
        Set Plage = Sheets("Suivi").Range("I6:I300")
        For Each c In Plage
            If Not IsEmpty(c) Then
                    With wk.Sheets("Reporting")
                    Lig = .Range("A" & .Rows.Count).End(xlUp).Row + 1
                    .Range("A" & Lig) = Sheets("Suivi").Range("A" & c.Row)
                    .Range("B" & Lig) = Sheets("Suivi").Range("B" & c.Row)
                    .Range("C" & Lig) = Sheets("Suivi").Range("C" & c.Row)
                    .Range("D" & Lig) = Sheets("Suivi").Range("D" & c.Row)
                    .Range("E" & Lig) = Sheets("Suivi").Range("G" & c.Row)
                End With
            End If
        Next c
        
        On Error GoTo 0
        Set Plage = Sheets("Suivi").Range("E6:E300")
        For Each c In Plage
            If IsEmpty(c) Then
                    With wk.Sheets("Reporting")
                    Lig = .Range("A" & .Rows.Count).End(xlUp).Row + 1
                    .Range("A" & Lig) = Sheets("Suivi").Range("A" & c.Row)
                    .Range("B" & Lig) = Sheets("Suivi").Range("B" & c.Row)
                    .Range("C" & Lig) = Sheets("Suivi").Range("C" & c.Row)
                    .Range("D" & Lig) = Sheets("Suivi").Range("D" & c.Row)
                    .Range("E" & Lig) = Sheets("Suivi").Range("G" & c.Row)
                End With
            End If
        Next c
        
  If Not wk Is Nothing Then
       wk.Save
       wk.Close
  End If
  
End Sub

Le problème c'est que ma macro met environ 15 secondes pour réaliser ce que je demande. Avant le rajout, elle faisait ça à un temps record.
J'ai du louper quelque chose, non ?
Pouvez-vous m'éclairer ?

Je vous remercie d'avance.

Bonne journée à tous et à toutes.
 
Vote positif 0 Vote négatif
A

Angy1105

XLDnaute Junior
Re : Question pour transfert de données

Bonjour le forum,

Me revoilà pour apprendre de nouvelles choses, :).
Je voudrais savoir s'il est possible de fusionner les deux lignes de code suivantes :

Code: 
   On Error GoTo 0
        Set Plage = Sheets("Suivi").Range("I6:I300")
        For Each c In Plage
            If Not IsEmpty(c) Then
                    With wk.Sheets("Reporting")
                    Lig = .Range("A" & .Rows.Count).End(xlUp).Row + 1
                    .Range("A" & Lig) = Sheets("Suivi").Range("A" & c.Row)
                    .Range("B" & Lig) = Sheets("Suivi").Range("B" & c.Row)
                    .Range("C" & Lig) = Sheets("Suivi").Range("C" & c.Row)
                    .Range("D" & Lig) = Sheets("Suivi").Range("D" & c.Row)
                    .Range("E" & Lig) = Sheets("Suivi").Range("G" & c.Row)
                End With
            End If
        Next c
        
        On Error GoTo 0
        Set Plage = Sheets("Suivi").Range("E6:E300")
        For Each c In Plage
            If IsEmpty(c) Then
                    With wk.Sheets("Reporting")
                    Lig = .Range("A" & .Rows.Count).End(xlUp).Row + 1
                    .Range("A" & Lig) = Sheets("Suivi").Range("A" & c.Row)
                    .Range("B" & Lig) = Sheets("Suivi").Range("B" & c.Row)
                    .Range("C" & Lig) = Sheets("Suivi").Range("C" & c.Row)
                    .Range("D" & Lig) = Sheets("Suivi").Range("D" & c.Row)
                    .Range("E" & Lig) = Sheets("Suivi").Range("G" & c.Row)
                End With
            End If
        Next c

Ces lignes représentent le transfert de données vers un autre fichier avec deux conditions différentes :
- si une cellule de la colonne I est vide, on transfert la ligne correspondante
- Si une cellule de la colonne E n'est pas vide, on transfert la ligne correspondante.

Est-ce qu'on peut écrire plus simplement ?
Le but de ma demande est d'optimiser le temps d'exécution de la macro.

Avez-vous une solution ?

Bonne journée à tous et à toutes.
 
Vote positif 0 Vote négatif
A

Angy1105

XLDnaute Junior
Re : Question pour transfert de données

Bonjour james,

Mes blocs de codes sont identiques sauf les conditions :
Pour I6:I50, la condition est If Not Is Empty.
Pour E6:E50, la condition est If Is Empty.
Par contre les données à transférer sont les mêmes.

Je dois avoir un souci dans mon code car la macro est très longue.

Merci de te pencher sur mon problème.

Bonne journée.
 
Vote positif 0 Vote négatif
A

Angy1105

XLDnaute Junior
Re : Question pour transfert de données

Bonjour à tous et à toutes,

Je rencontre encore un soucis lorsque j'appuis sur le bouton "Transfert" pour transférer mes données sur les autres fichiers Excel, une erreur apparaît :
Erreur d'éxécution '91', Variable objet ou variable de bloc With non définie.

J'utilise la macro suivante :
Code: 
Private Sub Transfertdonnées_Click()
    Dim wk As Workbook
    Dim Plage As Range
    Dim c As Range
    Dim Lig As Long
    Dim i As Byte
      
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False

    On Error Resume Next
    Set wk = Workbooks("SYNTHESE.xls")
    If Err > 0 Then
        Err.Clear
        Set wk = Workbooks.Open(ThisWorkbook.Path & "\SYNTHESE.xls")
    End If
    ThisWorkbook.Activate
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
 
    If Err.Number > 0 Then
        MsgBox "Erreur lors de l'ouverture du fichier SYNTHESE.xls", vbCritical, "Exportation"
        Exit Sub
    End If

    On Error GoTo 0
    Lig = wk.Sheets("Secteur").Range("A500").End(xlUp).Row + 1
    For i = 1 To 4
        wk.Sheets("Secteur").Cells(Lig, i + 3) = Sheets("Trame").Range("J24,L24,L26,J26").Areas(i)(1)
    Next i

    On Error GoTo 0
    Lig = wk.Sheets("Secteur").Range("A500").End(xlUp).Row + 1
    For i = 1 To 2
        wk.Sheets("Secteur").Cells(Lig, i) = Sheets("Trame").Range("D3,D5").Areas(i)(1)
    Next i
    
  If Not wk Is Nothing Then
       wk.Save
       wk.Close
       Set wk = Nothing
  End If

    On Error Resume Next
    Set wk = Workbooks("SUIVI&REPORTING.xls")
    If Err > 0 Then
        Err.Clear
        Set wk = Workbooks.Open(ThisWorkbook.Path & "\SUIVI&REPORTING.xls")
    End If
    ThisWorkbook.Activate
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
 
    If Err.Number > 0 Then
        MsgBox "Erreur lors de l'ouverture du fichier SUIVI&REPORTING.xls", vbCritical, "Exportation"
        Exit Sub
    End If

    On Error GoTo 0
        Set Plage = Sheets("Trame").Range("E11:E20")
        For Each c In Plage
            If UCase(c.Text) = "X" Then
                [COLOR="Red"]With wk.Sheets("Liste")[/COLOR]
                    Lig = .Range("A" & .Rows.Count).End(xlUp).Row + 1
                    .Range("A" & Lig) = Sheets("Trame").Range("D3")
                    .Range("B" & Lig) = Sheets("Trame").Range("D5")
                    .Range("C" & Lig) = Sheets("Trame").Range("B" & c.Row)
                    .Range("D" & Lig) = Sheets("Trame").Range("F" & c.Row)
                    .Range("E" & Lig) = Sheets("Trame").Range("I" & c.Row)
                    .Range("F" & Lig) = Sheets("Trame").Range("J" & c.Row)
                    .Range("G" & Lig) = Sheets("Trame").Range("K" & c.Row)
                    .Range("H" & Lig) = .Range("A" & Lig) = Sheets("Trame").Range("D3") + .Range("E" & Lig) = Sheets("Trame").Range("I" & c.Row)
                End With
            End If
        Next c
        
  If Not wk Is Nothing Then
       wk.Save
       wk.Close
       Set wk = Nothing
       
  End If

     On Error Resume Next
    Set wk = Workbooks("HIPO.xls")
    If Err > 0 Then
        Err.Clear
        Set wk = Workbooks.Open(ThisWorkbook.Path & "\HIPO.xls")
    End If
    ThisWorkbook.Activate
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
 
    If Err.Number > 0 Then
        MsgBox "Erreur lors de l'ouverture du fichier HIPO.xls", vbCritical, "Exportation"
        Exit Sub
    End If

    On Error GoTo 0
        Set Plage = Sheets("Trame").Range("M11:M20")
        For Each c In Plage
            If UCase(c.Text) = "VRAI" Then
                With wk.Sheets("Suivi")
                    Lig = .Range("A" & .Rows.Count).End(xlUp).Row + 1
                    .Range("A" & Lig) = Sheets("Trame").Range("D3")
                    .Range("B" & Lig) = Sheets("Trame").Range("D5")
                    .Range("C" & Lig) = Sheets("Trame").Range("B" & c.Row)
                    .Range("D" & Lig) = Sheets("Trame").Range("F" & c.Row)
                    .Range("E" & Lig) = Sheets("Trame").Range("J" & c.Row)
                    
                End With
            End If
        Next c

  If Not wk Is Nothing Then
       wk.Save
       wk.Close
       Set wk = Nothing
  End If
   
End Sub

Il détecte un problème au niveau de cette phrase "With wk.Sheets("Liste")"(en rouge)
Ce que je ne comprends pas c'est que lorsque j'ouvre MVB et que j'exécute ma macro tout fonctionne à merveille.

Pouvez vous m'aider ?

Merci d'avance et bonne journée.
 
Vote positif 0 Vote négatif

Discussions similaires

P
  • Question
Microsoft 365 Problème de destination à l'exécution d'une macro
Réponses
2
Affichages
283
Pimpon974
P
F
  • Question
Microsoft 365 Poursuivre ou pas la macro
Réponses
2
Affichages
185
Francky79
F
M
  • Question
Microsoft 365 Modifier code et format textbox
2 3
Réponses
35
Affichages
719
Marvin57
M
Chaton0408
  • Question
Microsoft 365 VBA Création Question liste destinataire
Réponses
6
Affichages
146
youky(BJ)
youky(BJ)
C
  • Question
Autres Enregistrer un code barre dans la cellule avant le titre qui est déja enregistré
Réponses
11
Affichages
496
Chatron
C
B
  • Résolu(e)
Microsoft 365 Besoin d'aide pour faire fonctionner 2 codes VBA ensemble
Réponses
2
Affichages
143
BenExcel
B
C
  • Résolu(e)
XL 2021 Remplir données devis en vba avec descriptions/quantités/PUs alignés
2
Réponses
18
Affichages
470
Phil69970
Phil69970
R3n0W
  • Résolu(e)
XL 2016 If Not xRgSel Is Nothing Then --> Ne marche pas
Réponses
10
Affichages
166
R3n0W
R3n0W
chaelie2015
  • Question
XL 2013 Réduire un code
Réponses
0
Affichages
242
chaelie2015
chaelie2015
F
  • Question
XL 2019 erreur 1004
Réponses
8
Affichages
235
florian50470
F

Membres actuellement en ligne

20 membres et 127 invités.

Partager cette page

Tutos vidéos

Power Query : Ajouter des requêtes (Excel et Power BI)
Créez votre première fonction LAMBDA dans Excel en 3 étapes!
LAMBDA, l’arme secrète de Microsoft pour Excel !
Office Insider - Découvrez les nouveautés Excel avant tout le monde

Statistiques des forums

Discussions
312 220
Messages
2 086 376
Membres
103 198
dernier inscrit
CACCIATORE