Copier / Coller depuis un Feuillet vers un autre si condition

Bonsoir à tous,

Je travaille sur ce script au bureau afin qu'à terme, je puisse générer des organigrammes à partir d'extractions du personnel.

(pour la petite histoire, je pouvais le faire via Visio, mais je n'avais pas la possibilité de synchroniser avec une base de donnée, et il me fallait de toute manière faire du traitement en amont, c'est pourquoi j'essaye de créer ces organigrammes "à la volée")

Pour ce faire, je colle mon extraction dans un onglet, elle est traitée dans un onglet "DB" (division par départements, etc)

et mon objectif est ensuite de coller 4 colonnes de ce traitement (Nom, poste, emplacement, manager...) dans un autre onglet, "Destination", qui servira de base à la création des organigrammes.

J'avais essayé dans un premier temps de ne copier que les cellules non-vides ou de supprimer la ligne dans le cas contraire, mais il arrivait qu'une des 4 colonnes soit vide, ce qui me faisait perdre toutes les infos du salarié.

J'ai donc préféré mettre un 0 sur les lignes à ne pas retenir et à filtrer en fonction.

Je n'y arrive malheureusement pas; j'ai beau tenter de modifier tel ou tel passage, c'est manifestement au dessus de mes compétences...

je sais que le traitement initial est un peu lourd avec les différents onglets; mais c'est précisément parce que je suis néophyte que j'ai préféré dans un premier temps séparer le tout en sous-projets, j'espère ensuite fusionner puis optimiser le tout.

Pourriez-vous m'aider s'il vous plait?

Je vous remercie

Sub sortdatabase()

Dim Destination As String

Dim finalrow As Integer

Dim i As Integer 'row counter

Sheets("Destination").Range("A2:D1000").ClearContents 'me permet de nettoyer la page avant de recoller les infos'

Destination = Sheets("Destination").Range("A2").Value

finalrow = Sheets("DB").Range("A1000").End(xlUp).row

For i = 2 To finalrow

        With Sheets("DB")

       If IsText(.Range(.Cells(i, 1), .Cells(i, 4))) Then 'ne retenir que les lignes ne comportant pas de 0'

       .Range(.Cells(i, 1), .Cells(i, 4)).Copy

        Sheets("Destination").Range("A2:D1000").End(xlUp).Offset(1, 0).PasteSpecial Paste:=xlPasteValues

        End If

End With

Next

End Sub

Bonjour,

à tester,

Sub Transfert_ligne_sans_0()
Dim sh1 As Worksheet, sh2 As Worksheet
Dim finalrow1 As Long, finalrow2 As Long, i As Long

Set sh1 = Sheets("DB")
Set sh2 = Sheets("Destination")

sh2.Range("A2:D1000000").ClearContents 'me permet de nettoyer la page avant de recoller les infos'

finalrow1 = sh1.Cells(Rows.Count, 1).End(xlUp).Row  'derniere ligne de la feuille "DB"

For i = 2 To finalrow1
  If Application.CountIf(sh1.Range(Cells(i, 1).Address, Cells(i, 4).Address), 0) = 0 Then 'ne retenir que les lignes ne comportant pas de 0'
    finalrow2 = sh2.Cells(Rows.Count, 1).End(xlUp).Row + 1 'derniere ligne de la feuille "Destination" + 1
    sh2.Range(Cells(finalrow2, 1).Address, Cells(finalrow2, 4).Address) = sh1.Range(Cells(i, 1).Address, Cells(i, 4).Address).Value
  End If
Next
End Sub

Bonjour,

Merci beaucoup tout, cela fonctionne 😁