Code VBA avec condition if + copie autre classeur

Le 03/01/2019 à 16:26

Bonjour à tous ,

Débutante en Code VBA , j'aurai besoin d'aide pour me faire gagner du temps sur une tâche quotidienne.

Je souhaiterai qu'il me coupe ( dans le fichier "1= base de donnée") et qui colle ( dans un autre "fichier 2 = archivage ligne 2019")tout les lignes entières si il Ya le mot "TERMINER" dans les cellules ( colonne B du fichier 1donc si dans B1,B2.....B500.... Jai TERMINER) .

Avec si possible un Message box m'indiquant le nbr de ligne qu'il va couper et coller .

j'ai regardé 2/3 code :

If [CONDITION ICI] Then ' => SI condition validée ALORS

'Instructions si vrai

Else ' => SINON

'Instructions si faux

End If

Apres pour mon fichier 2 : j'aurai des variables

Dim i As Long

i = .Range("A" & Rows.count).End(xlUp).Row + 1

Puis après les wookbook a définir pas rapport a mon chemin d'accès de mon fichier 2

Je pense que je suis passer à coter de pas mal de choses, je n'arrive pas a regrouper toutes ces variable / code

Merci d'avance pour votre aide

Cordialement et Meilleurs Vœux à tous 2019

Le 03/01/2019 à 17:37

bonjour

tu veux faire sur informatique comme sur papier en 1970

il FAUT faire de l'informatique, c'est à dire ne pas disperser des données d'une base à une autre.

dans ton fichier, il te suffit de filtrer la colonne contenant les TERMINE pour ne voir que ce qui n'est pas terminé, et inversement pour ne voir que les archives

aucune formule, aucun VBA. Rien !

il faut juste connaître la fonction de filtre d'Excel

bonne année

amitiés

Le 04/01/2019 à 08:51

Bonjour JMD , et merci pour ta réponse , que je comprend et conçois.

Cependant actuellement c'est déjà se que je fait mais mon fichier étant lourd car 5 000 lignes sur 200 colonnes avec formules cela prend de la mémoire et ralenti l'ouverture du fichier les recherches etc....

De plus ses un fichier partagé :/

n'y aurait-il pas d'autres solutions?

Cordialement

Le 04/01/2019 à 16:12

re

mon avis perso : avec 200 colonnes, tu dois galérer, même en ne conservant que quelques lignes

c'est quoi toutes ces colonnes ?

Le 06/01/2019 à 14:14

Re

Oui la galère tu as totalement raison !! toutes ces colonnes corresponde a un flux logistique de la recption a l'expedition en passant par toutes les informations nécéssaires. C'est un fichier exel tres lourd donc en partages avec différents services.

Le 06/01/2019 à 14:28

jai regarder quelque forum se qui ma donner sa comme code , cependant celui- ci est colle les ligne sur un autree onglet

Sub test()

Dim dlg As Integer, lg As Integer, i As Integer

With ActiveSheet

dlg = .Range("A" & Rows.Count).End(xlUp).Row

For i = dlg To 2 Step -1

If UCase(Range("I" & i)) = "OK" Then

lg = Sheets("ARCHIVE").Range("A" & Rows.Count).End(xlUp).Row + 1

.Range("A" & i & ":I" & i).Copy Sheets("ARCHIVE").Range("A" & lg)

.Rows(i).Delete

End If

Next

End With

End Sub

quand pensez-vous ?

Merci

Le 06/01/2019 à 20:23

Bonsoir fleurmi, jmd

On suppose que les 2 fichiers sont dans le même dossier.

La macro est à placer dans un module du fichier "archivage"

Attention au nom des fichiers et des feuilles à traiter 

Option Explicit
Sub test()
Dim rng As Range
    Application.ScreenUpdating = False
    With Workbooks.Open(ThisWorkbook.Path & "\base_donnee.xls")
        With .Sheets("Feuil1")
            .AutoFilterMode = False
            With .Range("a1").CurrentRegion
                .AutoFilter 2, "terminer"
                On Error Resume Next
                Set rng = .Offset(1).Resize(.Rows.Count - 1).SpecialCells(xlCellTypeVisible)
                On Error GoTo 0
                If Not rng Is Nothing Then
                    rng.Copy
                    With ThisWorkbook.Sheets("archive")
                        .Range("a" & Rows.Count).End(xlUp)(2) _
                                .PasteSpecial xlPasteValues
                    End With
                    MsgBox "Copie de " & Application.Subtotal(3, Columns("b")) - 1 & " ligne(s)"
                End If
                .AutoFilter
            End With
        End With
        .Close False
    End With
    Application.ScreenUpdating = True
End Sub

klin89

Le 08/01/2019 à 17:01

Bonjour Klin89,

un Grand merci a toi pour ce code , ses totalement mes besoins .

Cependant je viens de copier le code et modifié le nom des feuilles/classeurs.. il m'affiche un message d'erreur 400 :/

j'ai bien un dossier dedans 2 fichier ; 1=base dont 1 feuille nommé base / 2=archive dont 1 feuille nommé archive

ci-joint un copie d'écran

je regarde plus attentivement ce soir.

merci beaucoup , si cela pouvait marcher sa me changera mai journée de boulo

Cordialement

capture
Le 08/01/2019 à 18:42

ah je viens de penser sur mon fichier "archive" jai des entetes de colonnes identiques a mon 1 er fichier . :/

Le 08/01/2019 à 18:48

Re fleurmi,

Il faut bien placer le code dans un module standard du fichier "archive", le fichier "base" restant fermé.

J'ai réajusté le code puisqu'il faut supprimer les lignes filtrées du fichier base.

Option Explicit
Sub test()
Dim rng As Range
    Application.ScreenUpdating = False
    'ouverture du fichier source
    With Workbooks.Open(ThisWorkbook.Path & "\base.xlsx")
        With .Sheets("base")
            .AutoFilterMode = False
            With .Range("a1").CurrentRegion
                'filtre des donnees sur la 2eme colonne
                .AutoFilter 2, "terminer"
                On Error Resume Next
                'les lignes visibles sans la ligne d'en-tetes
                Set rng = .Offset(1).Resize(.Rows.Count - 1).SpecialCells(xlCellTypeVisible)
                On Error GoTo 0
                If Not rng Is Nothing Then
                    'copie les lignes filtrees
                    rng.Copy
                    'colle les lignes filtrees dans le fichier cible
                    With ThisWorkbook.Sheets("archive")
                        .Range("a" & Rows.Count).End(xlUp)(2) _
                                .PasteSpecial xlPasteValues
                    End With
                    MsgBox "Copie de " & Application.Subtotal(3, .Columns("b")) - 1 & " ligne(s)"
                    'suppression des lignes filtrees du fichier source
                    rng.EntireRow.Delete
                Else
                    MsgBox "Aucune donnée à copier"
                End If
                .AutoFilter
            End With
        End With
        'fermeture du fichier source et enregistrement des modifications
        .Close True
    End With
    Set rng = Nothing
    Application.ScreenUpdating = True
End Sub

J'ai considéré que tes données en feuille "base" commençaient en A1 avec une ligne d'en-têtes, idem dans l'autre fichier feuille "archive".

klin89

Le 08/01/2019 à 20:58

Salut fleurmi ,jmd, Klin89

regarder cette proposition :

'attention ==> "terminer" <> "TERMINER"

Sub test()
Dim i, drnB, drnA, cntr%
Dim W_Source, Sh_Source, W_Destination, Sh_Destination
Dim archv, bseD
Application.ScreenUpdating = False

'******########******
W_Source = "base.xlsm"
Sh_Source = "base"
W_Destination = "archive.xlsx"
Sh_Destination = "archive"
'******########******

Set bseD = Workbooks(W_Source).Sheets(Sh_Source)
Workbooks.Open (ThisWorkbook.Path & "\" & W_Destination)
Set archv = Workbooks(W_Destination).Sheets(Sh_Destination)

On Error Resume Next
drnB = bseD.Range("B" & Rows.Count).End(xlUp).Row
drnA = archv.Range("B" & Rows.Count).End(xlUp).Row + 1

   For i = 1 To drnB
     If bseD.Range("B" & i).Value = "terminer" Then 'ucase(bseD.Range("B" & i).Value) = ucase("terminer")
     'attention ==> "terminer" <> "TERMINER"
        archv.Range("A" & drnA).EntireRow.Value = bseD.Range("A" & i).EntireRow.Value
        bseD.Range("A" & i).EntireRow.Value = ""
        cntr = cntr + 1
     End If
     Next
        MsgBox "Copie de : " & cntr & " ligne(s)"
        Workbooks(W_Destination).Save
        Workbooks(W_Destination).Close True

Application.ScreenUpdating = True
End Sub
15base.xlsm (18.22 Ko)
Le 11/01/2019 à 12:08

Bonjour Klin89 ,

Merci pour ton code , ca marche nikel

j'ai compris qu'il n'était pas dans un "module standard" => insertion module ...

Bonjour AMIR,

Merci aussi beaucoup pour ton code , qui fonctionne également

De vos yeux d'expert je ne vois pas réellement quelle est la différence entre ses 2 codes ?

De plus pensez vous qu'il faut mieux faire marcher cette macro en fichier Excel "départager" ou cela posera pas de soucis sur un Excel partager ?

PS : Dans la continuité de ce code , j'ai voulu aller plus loin en incluant un trie automatique de la colonne R (date) du fichier base du plus ancien au plus récent. Jai essayer de l'inséré dans celui-ci déjà existant regardez ,quand pensez-vous ?

code simple :

ActiveWorkbook.Worksheets("base").AutoFilter.Sort.SortFields.Clear

ActiveWorkbook.Worksheets("base").AutoFilter.Sort.SortFields.Add Key:=Range( _

"R2"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _

xlSortNormal

With ActiveWorkbook.Worksheets("base").AutoFilter.Sort

.Header = xlYes

.MatchCase = False

.Orientation = xlTopToBottom

.SortMethod = xlPinYin

.Apply

End With

ActiveWorkbook.Worksheets("base").AutoFilter.Sort.SortFields.Clear

Windows("archive.xlsm").Activate

.Close True

End With

Set rng = Nothing

Application.ScreenUpdating = True

code avec l'ancien ;

Option Explicit

Sub test()

Dim rng As Range

Application.ScreenUpdating = False

'ouverture du fichier source

With Workbooks.Open(ThisWorkbook.Path & "\base.xlsx")

With .Sheets("base")

.AutoFilterMode = False

With .Range("a1").CurrentRegion

'filtre des donnees sur la 2eme colonne

.AutoFilter 2, "terminé"

On Error Resume Next

'les lignes visibles sans la ligne d'en-tetes

Set rng = .Offset(1).Resize(.Rows.Count - 1).SpecialCells(xlCellTypeVisible)

On Error GoTo 0

If Not rng Is Nothing Then

'copie les lignes filtrees

rng.Copy

'colle les lignes filtrees dans le fichier cible

With ThisWorkbook.Sheets("archive")

.Range("a" & Rows.Count).End(xlUp)(2) _

.PasteSpecial xlPasteValues

End With

MsgBox "Copie de " & Application.Subtotal(3, .Columns("b")) - 1 & " ligne(s)"

'suppression des lignes filtrees du fichier source

rng.EntireRow.Delete

Else

MsgBox "Aucune donnée à copier"

End If

.AutoFilter

End With

End With

'nouveau code de tri de la colonne R sur le fichier de base avant l'enregistrement et fermeture .

ActiveWorkbook.Worksheets("base").AutoFilter.Sort.SortFields.Clear

ActiveWorkbook.Worksheets("base").AutoFilter.Sort.SortFields.Add Key:=Range( _

"R2"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _

xlSortNormal

With ActiveWorkbook.Worksheets("base").AutoFilter.Sort

.Header = xlYes

.MatchCase = False

.Orientation = xlTopToBottom

.SortMethod = xlPinYin

.Apply

End With

ActiveWorkbook.Worksheets("base").AutoFilter.Sort.SortFields.Clear

Windows("archive.xlsm").Activate

.Close True

End With

Set rng = Nothing

Application.ScreenUpdating = True

End With

'fermeture du fichier source et enregistrement des modifications

.Close True

End With

Set rng = Nothing

Application.ScreenUpdating = True

End Sub

Je reviens se soir sur le Forum

merci a vous

Cordialement

Le 15/01/2019 à 11:18

Bonjour Klin89 ,

Merci pour ton code , ca marche nikel

j'ai compris qu'il n'était pas dans un "module standard" => insertion module ...

Bonjour AMIR,

Merci aussi beaucoup pour ton code , qui fonctionne également

De vos yeux d'expert je ne vois pas réellement quelle est la différence entre ses 2 codes ?

De plus pensez vous qu'il faut mieux faire marcher cette macro en fichier Excel "départager" ou cela posera pas de soucis sur un Excel partager ?

PS : Dans la continuité de ce code , j'ai voulu aller plus loin en incluant un trie automatique de la colonne R (date) du fichier base du plus ancien au plus récent. Jai essayer de l'inséré dans celui-ci déjà existant regardez ,quand pensez-vous ?

code simple :

 ActiveWorkbook.Worksheets("base").AutoFilter.Sort.SortFields.Clear
 ActiveWorkbook.Worksheets("base").AutoFilter.Sort.SortFields.Add Key:=Range( _
 "R2"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
 xlSortNormal
 With ActiveWorkbook.Worksheets("base").AutoFilter.Sort
 .Header = xlYes
 .MatchCase = False
 .Orientation = xlTopToBottom
 .SortMethod = xlPinYin
 .Apply
 End With
 ActiveWorkbook.Worksheets("base").AutoFilter.Sort.SortFields.Clear
 Windows("archive.xlsm").Activate
 .Close True
 End With
 Set rng = Nothing
 Application.ScreenUpdating = True
code avec l'ancien ;

 Option Explicit
 Sub test()
 Dim rng As Range
 Application.ScreenUpdating = False
 'ouverture du fichier source
 With Workbooks.Open(ThisWorkbook.Path & "\base.xlsx")
 With .Sheets("base")
 .AutoFilterMode = False
 With .Range("a1").CurrentRegion
 'filtre des donnees sur la 2eme colonne
 .AutoFilter 2, "terminé"
 On Error Resume Next
 'les lignes visibles sans la ligne d'en-tetes
 Set rng = .Offset(1).Resize(.Rows.Count - 1).SpecialCells(xlCellTypeVisible)
 On Error GoTo 0
 If Not rng Is Nothing Then
'copie les lignes filtrees
 rng.Copy
 'colle les lignes filtrees dans le fichier cible
 With ThisWorkbook.Sheets("archive")
 .Range("a" & Rows.Count).End(xlUp)(2) _
 .PasteSpecial xlPasteValues
 End With
 MsgBox "Copie de " & Application.Subtotal(3, .Columns("b")) - 1 & " ligne(s)"
 'suppression des lignes filtrees du fichier source
 rng.EntireRow.Delete
 Else
 MsgBox "Aucune donnée à copier"
 End If
 .AutoFilter
 End With
 End With
'nouveau code de tri de la colonne R sur le fichier de base avant l'enregistrement et fermeture .

 ActiveWorkbook.Worksheets("base").AutoFilter.Sort.SortFields.Clear
 ActiveWorkbook.Worksheets("base").AutoFilter.Sort.SortFields.Add Key:=Range( _
 "R2"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
 xlSortNormal
 With ActiveWorkbook.Worksheets("base").AutoFilter.Sort
 .Header = xlYes
 .MatchCase = False
 .Orientation = xlTopToBottom
 .SortMethod = xlPinYin
 .Apply
 End With
 ActiveWorkbook.Worksheets("base").AutoFilter.Sort.SortFields.Clear
 Windows("archive.xlsm").Activate
 .Close True
 End With
 Set rng = Nothing
 Application.ScreenUpdating = True
 End With
 'fermeture du fichier source et enregistrement des modifications
 .Close True
 End With
 Set rng = Nothing
 Application.ScreenUpdating = True
 End Sub

Je reviens se soir sur le Forum

merci a vous

Cordialement

Le 15/01/2019 à 18:28

re fleurmi,

Le tri peut s'effectuer au début de la procédure, cela ne change rien au résultat final, non 

Option Explicit
Sub test()
Dim rng As Range
    Application.ScreenUpdating = False
    'ouverture du fichier source
    With Workbooks.Open(ThisWorkbook.Path & "\base.xlsx")
        With .Sheets("base")
            .AutoFilterMode = False
            With .Range("a1").CurrentRegion
                'tri sur la colonne "R"
                .Sort key1:=.Cells(1, 18), order1:=xlAscending, Header:=xlYes
                'filtre des donnees sur la 2eme colonne
                .AutoFilter 2, "terminer"
                On Error Resume Next
                'les lignes visibles sans la ligne d'en-tetes
                Set rng = .Offset(1).Resize(.Rows.Count - 1).SpecialCells(xlCellTypeVisible)
                On Error GoTo 0
                If Not rng Is Nothing Then
                    'copie les lignes filtrees
                    rng.Copy
                    'colle les lignes filtrees dans le fichier cible
                    With ThisWorkbook.Sheets("archive")
                        .Range("a" & Rows.Count).End(xlUp)(2) _
                                .PasteSpecial xlPasteValues
                    End With
                    MsgBox "Copie de " & Application.Subtotal(3, .Columns("b")) - 1 & " ligne(s)"
                    'suppression des lignes filtrees du fichier source
                    rng.EntireRow.Delete
                Else
                    MsgBox "Aucune donnée à copier"
                End If
                .AutoFilter
            End With
        End With
        'fermeture du fichier source et enregistrement des modifications
        .Close True
    End With
    Set rng = Nothing
    Application.ScreenUpdating = True
End Sub

klin89

Rechercher des sujets similaires à "code vba condition copie classeur"