Transférer des données d'un onglet à l'autre si condition

Le 18/02/2020 à 15:18

Bonjour au forum,

Pour un fichier de gestion d'une banque d'ADN, je souhaiterais, via une macro, pouvoir copier des données (si "Oui" est renseigné dans une des cellules de la ligne à copier) d'une feuille vers une autre feuille, dans la dernière ligne vide.

Les étapes plus détaillées que je souhaiterais effectuer par cette macros sont :

1°/ si "Oui" dans la colonne L de cette feuille, copier la/les ligne(s) concernée(s) de la colonne C à la colonne K de cette feuille puis coller les valeurs dans la feuille "VIDNA", à partir de la ligne n°10 (toujours dans les colonnes C à K) pour le 1er collage puis à la 1ere ligne vide pour les suivants.

2°/Police barrée + gras italique les données copiées de la/les ligne(s) concernée(s) de cette feuille des colonnes A à J, puis écrire dans la cellule colonne K "Déplacé en VIDNA : ligne n°"x"", x étant le numéro de ligne où les données ont été collées dans la feuille "VIDNA", puis mettre la valeur "OK" dans la colonne L (voir feuille "Après macro" pour visualiser le résultat attendu)

3°/ Dans l'idéal... Lors du collage dans la feuille VIDNA, incrémenter à chaque ajout d'une ligne selon le schéma ci-dessous :

  • Dans la colonne A : VIDNA1 jusqu'au 64ième collage inclus, puis passer à VIDNA2 pour les 64 itérations suivantes, puis passer à VIDNA3, etc
  • Dans la conne B : de 1 à 64 puis retour à 1 (qui doit logiquement correspondre à l'incrémentation dans la colonne A)

Ci-joint un fichier exemple, avec les explications

Merci d'avance pour l'aide que vous pourriez m'apporter.

Nico.

21fof2.xlsx (18.26 Ko)
Le 18/02/2020 à 17:19

Bonjour Nrev74, le forum,

Un début de réponse......je n'ai pas traité les colonnes A & B de la feuille VIDNA....

Spoiler
Option Compare Text

Sub test()
 Dim sh1 As Worksheet, sh2 As Worksheet
 Dim dl1 As Long, dl2 As Long
 Dim i As Long

  Set sh1 = Sheets("Avant macro")
      dl1 = sh1.Range("A" & Rows.Count).End(xlUp).Row
  Set sh2 = Sheets("VIDNA")
      dl2 = sh2.Range("C" & Rows.Count).End(xlUp).Row + 1

      Application.ScreenUpdating = False

    With sh1
     For i = 10 To dl1
      If .Range("L" & i) = "Oui" And .Range("A" & i).Font.Strikethrough = False Then
      .Range("C" & i & ":K" & i).Copy sh2.Range("C" & dl2)
       dl2 = dl2 + 1
      .Range("A" & i & ":L" & i).Font.Strikethrough = True: Range("A" & i & ":L" & i).Font.Bold = True
      .Range("K" & i) = "Déplacé en VIDNA : ligne n° " & dl2 - 1
      .Range("L" & i) = "OK"
      End If
     Next i
    End With
End Sub
36fof2.xlsm (24.85 Ko)

Cordialement,

Le 18/02/2020 à 21:02

Re,

Nouvel essai qui prend en compte toutes les colonnes......le code n'est pas optimisé, mais dans l'attente de mieux,

73test.xlsm (24.79 Ko)

Bonne soirée,

Le 19/02/2020 à 07:07

Hello xorsankukai,

Merci beaucoup !

C'est une très bonne base pour moi, je vais tenter de l'adapter à mes besoins

Merci infiniment encore !

Nico.

Le 19/02/2020 à 12:02

Hello xorsankukai,

Je rencontre juste un tout petit problème lorsque toutes les valeurs sont à "Non" dans la colonne VIDNA sur cette ligne :

  If c1.Value = "" Then c1.Value = c1.Offset(-1, 0).Value + 1

J'ai une erreur d'incompatibilité de type 13.

Pour rappel, code complet :

Option Compare Text

Sub TransfertA()

 Dim sh1 As Worksheet, sh2 As Worksheet
 Dim dl1 As Long, dl2 As Long
 Dim i As Long
 Dim plage1 As Range, c1 As Range
 Dim plage2 As Range, C2 As Range

  Set sh1 = Sheets("Boîte A")
      dl1 = sh1.Range("B" & Rows.Count).End(xlUp).Row
  Set sh2 = Sheets("VIDNA")
      dl2 = sh2.Range("D" & Rows.Count).End(xlUp).Row + 1

      Application.ScreenUpdating = False

    With sh1
     For i = 10 To dl1
      If .Range("M" & i) = "Oui" And .Range("B" & i).Font.Strikethrough = False Then
      .Range("D" & i & ":L" & i).Copy sh2.Range("D" & dl2): sh2.Range("B" & dl2 & ":M" & dl2).Borders.Value = 1
       dl2 = dl2 + 1
      .Range("B" & i & ":K" & i).Font.Strikethrough = True: Range("B" & i & ":M" & i).Font.Bold = True
      .Range("L" & i) = "Déplacé en VIDNA : ligne n° " & dl2 - 1
      .Range("M" & i) = "OK"
      End If
     Next i
    End With

     With Sheets("VIDNA")
           dl = .Range("D" & Rows.Count).End(xlUp).Row
   Set plage1 = .Range("C10:C" & dl)
   Set plage2 = .Range("B10:B" & dl)

      a = 1
  For i = 10 To dl Step 64
    .Range("C" & i) = a
  Next i
  For Each c1 In plage1
    If c1.Value = "" Then c1.Value = c1.Offset(-1, 0).Value + 1
  Next c1

      b = 0
  For j = 10 To dl Step 64
    .Range("B" & j) = "VIDNA" & b + 1
      b = b + 1
  Next j
  For Each C2 In plage2
    If C2.Value = "" Then C2.Value = C2.Offset(-1, 0).Value
  Next C2
 End With
End Sub

Aurais-tu une solution pour éviter cela ?

Sinon tout fonctionne à merveille, merci infiniment...

Nico.

Le 19/02/2020 à 12:10

Re,

J'ai tenté une correction en rajoutant ceci :

For Each c1 In plage1
    If c1.Value = "" And c1.Offset(-1, 0).Value <> "Emplacement" Then c1.Value = c1.Offset(-1, 0).Value + 1
  Next c1

      b = 0
  For j = 10 To dl Step 64
    .Range("B" & j) = "VIDNA" & b + 1
      b = b + 1
  Next j
  For Each C2 In plage2
    If C2.Value = "" And C2.Offset(-1, 0).Value <> "N° boîte" Then C2.Value = C2.Offset(-1, 0).Value
  Next C2

Cela fonctionne mais je ne suis pas certain que ce soit très valable niveau programmation...

Le 19/02/2020 à 13:00

Bonjour Nrev74,

Merci pour ton retour,

J'ai rajouté une gestion d'erreur pour palier à ce problème.

Voici un nouvel essai, je ne suis pas non plus un pro de la programmation

9nrev74.xlsm (27.78 Ko)

Pour le remplissage des colonnes A et B de VIDNA, ce n'est pas top, mais je n'ai pas trouvé comment faire mieux.

En espérant qu'un pro passe dans le coin et te propose un code plus optimisé,

Cordialement,

Le 19/02/2020 à 14:55

Merci à toi pour ton implication

J'ai testé ta version et cela fonctionne parfaitement également.

Merci encore et excellente continuation à toi !

Le 19/02/2020 à 16:36

Re,

Merci pour tes remerciements,

Je pense avoir trouvé une meilleure solution, le code est plus fluide car une seule boucle....fonctionnel chez moi, j'espère qu'il en sera de même pour toi, 

Option Compare Text                                         'pour prendre en compte oui (que ce soit en majuscule où minuscule)

Sub test()
 Dim sh1 As Worksheet, sh2 As Worksheet                      'déclaration des variables Feuilles
 Dim dl1 As Long, dl2 As Long                                'déclaration des dernières lignes
 Dim i As Long
 Dim plage1 As Range, plage2 As Range, C As Range            'déclaration des plages et cellules

  Set sh1 = Sheets("Avant macro")                            'définition de la feuille sh1
      dl1 = sh1.Range("A" & Rows.Count).End(xlUp).Row        'définition de la dernière ligne
  Set sh2 = Sheets("VIDNA")                                  'définition de la feuille sh2
      dl2 = sh2.Range("C" & Rows.Count).End(xlUp).Row + 1    'définition de la première ligne vide de la colonne C (d'où le +1)

      Application.ScreenUpdating = False                     'désactive le rafraichissement de l'écran (évite le scintillement lors des boucles)

    With sh1                                                 'agit sur la feuille "Avant macro"
     For i = 10 To dl1                                       'boucle de la ligne 10 à la dernière
      If .Range("L" & i) = "Oui" And .Range("A" & i & ":L" & i).Font.Strikethrough = False Then 'si colonne L contient Oui et si la ligne n'est pas barrée
      .Range("C" & i & ":K" & i).Copy sh2.Range("C" & dl2): sh2.Range("A" & dl2 & ":L" & dl2).Borders.Value = 1   'on copie de C à K et on colle dans colonne C de la feuille "VIDNA"
       If dl2 = 10 Then                                      'si la première ligne vide est 10
        sh2.Range("A" & dl2) = "VIDNA" & 1                   'on écrit VIDNA1 an A10
        sh2.Range("B" & dl2) = 1                             'on écrit 1 en B10
       Else                                                  'sinon
        sh2.Range("A" & dl2) = sh2.Range("A" & dl2).Offset(-1, 0)      'on reprend la valeur précédente en A
        sh2.Range("B" & dl2) = sh2.Range("B" & dl2).Offset(-1, 0) + 1  'on incrémente de 1 la valeur précédente
       End If
       If sh2.Range("B" & dl2) = 65 Then              'si la valeur en colonne B=65
        sh2.Range("B" & dl2) = 1                      'on repart à 1
        sh2.Range("A" & dl2) = "VIDNA" & Right(sh2.Range("A" & dl2).Offset(-1, 0), Len(sh2.Range("A" & dl2).Offset(-1, 0)) - 5) + 1  'on incrémente de 1 la valeur précédente (je supprime VIDNA,je récupère le chiffre que j'incrémente de 1)
       End If
       dl2 = dl2 + 1                                         'on incrémente la dernière ligne de 1 pour pouvoir coller les lignes suivantes
      .Range("A" & i & ":L" & i).Font.Strikethrough = True: Range("A" & i & ":L" & i).Font.Bold = True  'police barrée et en gras de A à L
      .Range("K" & i) = "Déplacé en VIDNA : ligne n° " & dl2 - 1    'on écrit "Déplacé....ligne N°" et numéro de la ligne de la feuille VIDNA
      .Range("L" & i) = "OK"                                        'on écrit OK en colonne L
      End If
     Next i
    End With

End Sub
11nrev74.xlsm (26.33 Ko)

Cordialement,

Le 27/02/2020 à 10:09

Bonjour Xorsankukai,

Merci beaucoup pour cette nouvelle version

Du coup j'ai une petite question supplémentaire…

J'aimerais qu'un MsgBox s'affiche lorsque la condition a été OK au moins une fois, et un autre MsgBox lorsque la condition n'a pas été remplie.

Le problème est que je n'arrive pas à trouver une solution pour n'afficher le MsgBox qu'une seule fois et non pas à chaque itération où la condition n'est pas remplie…

Voici ce que j'ai tenté en dernier, avec le Exit For mais évidemment, on sort de la procédure dès la 1ère itération où la condition n'est pas remplie…

Aurais-tu une idée ?

With sh1                                                 'agit sur la feuille "Boîte A"
        For i = 10 To dl1                                       'boucle de la ligne 10 à la dernière
            If .Range("M" & i) = "Oui" And .Range("B" & i & ":K" & i).Font.Strikethrough = False Then 'si colonne M contient Oui et si la ligne n'est pas barrée
                .Range("D" & i & ":L" & i).Copy sh2.Range("E" & dl2) _
                : sh2.Range("B" & dl2 & ":N" & dl2).Borders.Value = 1 _
                : sh2.Range("B" & dl2 & ":N" & dl2).Borders(xlEdgeLeft).Weight = xlThick _
                : sh2.Range("B" & dl2 & ":N" & dl2).Borders(xlEdgeRight).Weight = xlThick _
                : sh2.Range("B" & dl2 & ":N" & dl2).Borders(xlEdgeTop).Weight = xlThin _
                : sh2.Range("B" & dl2 & ":N" & dl2).Borders(xlEdgeBottom).Weight = xlThick _
                : sh2.Range("B" & dl2 & ":M" & dl2).Locked = True                                'on copie de D à L et on colle dans colonne E de la feuille "VIDNA"
                dl2 = dl2 + 1                                         'on incrémente la dernière ligne de 1 pour pouvoir coller les lignes suivantes
                .Range("B" & i & ":K" & i).Font.Strikethrough = True: Range("B" & i & ":M" & i).Font.Bold = True: Range("B" & i & ":M" & i).Font.Italic = True  'police barrée et en gras de B à K/M
                .Range("L" & i) = "Déplacé en VIDNA : ligne n° " & dl2 - 10 'on écrit "Déplacé....ligne N°" et numéro de la ligne de la feuille VIDNA
                .Range("M" & i) = "OK"                                        'on écrit OK en colonne M
                MsgBox "Individu(s) transféré(s) avec succès en DNAThèque à vie", vbInformation + vbOKOnly, "Transfert effectué"
            Else
                MsgBox "Aucun individu à transférer en DNAThèque à vie", vbInformation + vbOKOnly, "Aucun transfert effectué"
                Exit For
            End If
        Next i
    End With

Merci d'avance !

EDIT : je vais créer un nouveau sujet vu que le problème est tout autre et que j'ai mis le sujet en résolu…

Le 27/02/2020 à 11:30

Re,

Merci pour le retour,

Un essai....

Option Compare Text                                         'pour prendre en compte oui (que ce soit en majuscule où minuscule)

Sub test()
 Dim sh1 As Worksheet, sh2 As Worksheet                      'déclaration des variables Feuilles
 Dim dl1 As Long, dl2 As Long                                'déclaration des dernières lignes
 Dim i As Long
 Dim plage1 As Range, plage2 As Range, C As Range            'déclaration des plages et cellules
 Dim msg As String                                           'déclaration de la variable message
 Dim compteur As Integer                                     'déclaration de la variable compteur

  Set sh1 = Sheets("Avant macro")                            'définition de la feuille sh1
      dl1 = sh1.Range("A" & Rows.Count).End(xlUp).Row        'définition de la dernière ligne
  Set sh2 = Sheets("VIDNA")                                  'définition de la feuille sh2
      dl2 = sh2.Range("C" & Rows.Count).End(xlUp).Row + 1    'définition de la première ligne vide de la colonne C (d'où le +1)

      Application.ScreenUpdating = False                     'désactive le rafraichissement de l'écran (évite le scintillement lors des boucles)

     compteur = 0                                            'compteur démarre à 0

    With sh1                                                 'agit sur la feuille "Avant macro"
     For i = 10 To dl1                                       'boucle de la ligne 10 à la dernière
      If .Range("L" & i) = "Oui" And .Range("A" & i & ":L" & i).Font.Strikethrough = False Then 'si colonne L contient Oui et si la ligne n'est pas barrée
      .Range("C" & i & ":K" & i).Copy sh2.Range("C" & dl2): sh2.Range("A" & dl2 & ":L" & dl2).Borders.Value = 1   'on copie de C à K et on colle dans colonne C de la feuille "VIDNA"
       msg = msg & Chr(10) & "La ligne  " & i & " a été déplacée sur la feuille VIDNA"   'définit le message
       compteur = compteur + 1                               'on compte le nombre de lignes répondant aux critères
       If dl2 = 10 Then                                      'si la première ligne vide est 10
        sh2.Range("A" & dl2) = "VIDNA" & 1                   'on écrit VIDNA1 an A10
        sh2.Range("B" & dl2) = 1                             'on écrit 1 en B10
       Else                                                  'sinon
        sh2.Range("A" & dl2) = sh2.Range("A" & dl2).Offset(-1, 0)      'on reprend la valeur précédente en A
        sh2.Range("B" & dl2) = sh2.Range("B" & dl2).Offset(-1, 0) + 1  'on incrémente de 1 la valeur précédente
       End If
       If sh2.Range("B" & dl2) = 65 Then              'si la valeur en colonne B=65
        sh2.Range("B" & dl2) = 1                      'on repart à 1
        sh2.Range("A" & dl2) = "VIDNA" & Right(sh2.Range("A" & dl2).Offset(-1, 0), Len(sh2.Range("A" & dl2).Offset(-1, 0)) - 5) + 1  'on incrémente de 1 la valeur précédente (je supprime VIDNA,je récupère le chiffre que j'incrémente de 1)
       End If
       dl2 = dl2 + 1                                         'on incrémente la dernière ligne de 1 pour pouvoir coller les lignes suivantes
      .Range("A" & i & ":L" & i).Font.Strikethrough = True: Range("A" & i & ":L" & i).Font.Bold = True  'police barrée et en gras de A à L
      .Range("K" & i) = "Déplacé en VIDNA : ligne n° " & dl2 - 1    'on écrit "Déplacé....ligne N°" et numéro de la ligne de la feuille VIDNA
      .Range("L" & i) = "OK"                                        'on écrit OK en colonne L
      End If
     Next i
    End With
     If compteur > 0 Then                   'si au moins une ligne transférée
      MsgBox msg                            'message avec les lignes transférées
     Else                                   'sinon
      MsgBox "Aucune ligne transférée"      'message : aucune ligne transférée
     End If
End Sub
20nrev74.xlsm (27.85 Ko)

Où plus simplement:

Option Compare Text                                         'pour prendre en compte oui (que ce soit en majuscule où minuscule)

Sub test()
 Dim sh1 As Worksheet, sh2 As Worksheet                      'déclaration des variables Feuilles
 Dim dl1 As Long, dl2 As Long                                'déclaration des dernières lignes
 Dim i As Long
 Dim plage1 As Range, plage2 As Range, C As Range            'déclaration des plages et cellules
 Dim compteur As Integer                                     'déclaration de la variable compteur

  Set sh1 = Sheets("Avant macro")                            'définition de la feuille sh1
      dl1 = sh1.Range("A" & Rows.Count).End(xlUp).Row        'définition de la dernière ligne
  Set sh2 = Sheets("VIDNA")                                  'définition de la feuille sh2
      dl2 = sh2.Range("C" & Rows.Count).End(xlUp).Row + 1    'définition de la première ligne vide de la colonne C (d'où le +1)

      Application.ScreenUpdating = False                     'désactive le rafraichissement de l'écran (évite le scintillement lors des boucles)

     compteur = 0                                            'compteur démarre à 0

    With sh1                                                 'agit sur la feuille "Avant macro"
     For i = 10 To dl1                                       'boucle de la ligne 10 à la dernière
      If .Range("L" & i) = "Oui" And .Range("A" & i & ":L" & i).Font.Strikethrough = False Then 'si colonne L contient Oui et si la ligne n'est pas barrée
      .Range("C" & i & ":K" & i).Copy sh2.Range("C" & dl2): sh2.Range("A" & dl2 & ":L" & dl2).Borders.Value = 1   'on copie de C à K et on colle dans colonne C de la feuille "VIDNA"
       compteur = compteur + 1                               'on compte le nombre de lignes répondant aux critères
       If dl2 = 10 Then                                      'si la première ligne vide est 10
        sh2.Range("A" & dl2) = "VIDNA" & 1                   'on écrit VIDNA1 an A10
        sh2.Range("B" & dl2) = 1                             'on écrit 1 en B10
       Else                                                  'sinon
        sh2.Range("A" & dl2) = sh2.Range("A" & dl2).Offset(-1, 0)      'on reprend la valeur précédente en A
        sh2.Range("B" & dl2) = sh2.Range("B" & dl2).Offset(-1, 0) + 1  'on incrémente de 1 la valeur précédente
       End If
       If sh2.Range("B" & dl2) = 65 Then              'si la valeur en colonne B=65
        sh2.Range("B" & dl2) = 1                      'on repart à 1
        sh2.Range("A" & dl2) = "VIDNA" & Right(sh2.Range("A" & dl2).Offset(-1, 0), Len(sh2.Range("A" & dl2).Offset(-1, 0)) - 5) + 1  'on incrémente de 1 la valeur précédente (je supprime VIDNA,je récupère le chiffre que j'incrémente de 1)
       End If
       dl2 = dl2 + 1                                         'on incrémente la dernière ligne de 1 pour pouvoir coller les lignes suivantes
      .Range("A" & i & ":L" & i).Font.Strikethrough = True: Range("A" & i & ":L" & i).Font.Bold = True  'police barrée et en gras de A à L
      .Range("K" & i) = "Déplacé en VIDNA : ligne n° " & dl2 - 1    'on écrit "Déplacé....ligne N°" et numéro de la ligne de la feuille VIDNA
      .Range("L" & i) = "OK"                                        'on écrit OK en colonne L
      End If
     Next i
    End With
     If compteur > 0 Then                   'si au moins une ligne transférée
      MsgBox "Transfert effectué"           'message transfert effectué
     Else                                   'sinon
      MsgBox "Aucune ligne transférée"      'message : aucune ligne transférée
     End If
End Sub
20nrev74.xlsm (27.85 Ko)

Cordialement,

Rechercher des sujets similaires à "transferer donnees onglet condition"