excel vba - copier/coller ligne spécifique à une autre feuille avec toutes sortes de formes si les conditions sont remplies

J'ai une situation assez spécifique. J'ai besoin de copier chaque ligne de sheet1 (ot.2) à sheet2 (odch.l.2) si la colonne "AD" dans cette rangée a dans la cellule "NOK" marque "x" ou "X". Les formes doivent rester avec les données. Jusqu'à présent, j'ai réussi à copier toutes les formes, qu'il y ait x ou X, tandis que les données dépendent de la présence de données x ou X - BUT et que les formes ne sont pas collées - les données sont triées les unes après les autres et les formes copié par la position dans la feuille de sourceexcel vba - copier/coller ligne spécifique à une autre feuille avec toutes sortes de formes si les conditions sont remplies

Je n'ai aucune idée de la façon de procéder, je suis novice dans ce domaine et j'apprécierais toute sorte d'aide.

si vous allez besoin d'un peu plus d'informations, s'il vous plaît laissez-moi savoir, je suis va montre ce fil tout le temps :-D merci

voici mon code:

Sub test150929() 

Application.ScreenUpdating = False 

    Dim DestSheet  As Worksheet 
    Dim Destsheet2  As Worksheet 
    Set DestSheet = Worksheets("odch.l.2") 
    Set Destsheet2 = Worksheets("ot.2") 
    Dim sRow  As Long  'row index on source worksheet 
    Dim dRow  As Long  'row index on destination worksheet 
    Dim sCount  As Long 
    Dim Range_to As Integer 
    Dim Cell As String 
    Dim oneShape As Shape 
    Dim myLeft As Single, myTop As Single 

    sCount = 0 
    dRow = 16 


      'DestSheet.Select 
      'Cell = Range("AM12") 
      'Range(Cells(15, 1), Cells(Cell, 39)).Select 


      Destsheet2.Select 
      Cell = "A15:AM" & Range("AM12") 
      Range_to = Range("AM12") 

      For Each oneShape In Destsheet2.Shapes 
     With oneShape 
      myLeft = .Left 
      myTop = .Top 
      .Copy 
     End With 
     With DestSheet 
      .Paste 
      With .Shapes(.Shapes.Count) 
       .Top = myTop 
       .Left = myLeft 
      End With 
     End With 
    Next oneShape 


    Destsheet2.Select 
      For sRow = 1 To Range_to 
       'use pattern matching to find "X" anywhere in cell 
       If Cells(sRow, "AD") Like "*X*" Then 
        sCount = sCount + 1 


        Cells(sRow, "A").Copy Destination:=DestSheet.Cells(dRow, "A") 
        Cells(sRow, "B").Copy Destination:=DestSheet.Cells(dRow, "B") 
        Cells(sRow, "C").Copy Destination:=DestSheet.Cells(dRow, "C") 
        Cells(sRow, "D").Copy Destination:=DestSheet.Cells(dRow, "D") 
        Cells(sRow, "E").Copy Destination:=DestSheet.Cells(dRow, "E") 
        Cells(sRow, "F").Copy Destination:=DestSheet.Cells(dRow, "F") 
        Cells(sRow, "G").Copy Destination:=DestSheet.Cells(dRow, "G") 
        Cells(sRow, "H").Copy Destination:=DestSheet.Cells(dRow, "H") 
        Cells(sRow, "I").Copy Destination:=DestSheet.Cells(dRow, "I") 
        Cells(sRow, "J").Copy Destination:=DestSheet.Cells(dRow, "J") 
        Cells(sRow, "K").Copy Destination:=DestSheet.Cells(dRow, "K") 
        Cells(sRow, "L").Copy Destination:=DestSheet.Cells(dRow, "L") 
        Cells(sRow, "M").Copy Destination:=DestSheet.Cells(dRow, "M") 
        Cells(sRow, "N").Copy Destination:=DestSheet.Cells(dRow, "N") 
        Cells(sRow, "O").Copy Destination:=DestSheet.Cells(dRow, "O") 
        Cells(sRow, "P").Copy Destination:=DestSheet.Cells(dRow, "P") 
        Cells(sRow, "Q").Copy Destination:=DestSheet.Cells(dRow, "Q") 
        Cells(sRow, "R").Copy Destination:=DestSheet.Cells(dRow, "R") 
        Cells(sRow, "S").Copy Destination:=DestSheet.Cells(dRow, "S") 
        Cells(sRow, "T").Copy Destination:=DestSheet.Cells(dRow, "T") 
        Cells(sRow, "U").Copy Destination:=DestSheet.Cells(dRow, "U") 
        Cells(sRow, "V").Copy Destination:=DestSheet.Cells(dRow, "V") 
        Cells(sRow, "W").Copy Destination:=DestSheet.Cells(dRow, "W") 
        Cells(sRow, "X").Copy Destination:=DestSheet.Cells(dRow, "X") 
        Cells(sRow, "Y").Copy Destination:=DestSheet.Cells(dRow, "Y") 
        Cells(sRow, "Z").Copy Destination:=DestSheet.Cells(dRow, "Z") 
        Cells(sRow, "AA").Copy Destination:=DestSheet.Cells(dRow, "AA") 
        Cells(sRow, "AB").Copy Destination:=DestSheet.Cells(dRow, "AB") 
        Cells(sRow, "AC").Copy Destination:=DestSheet.Cells(dRow, "AC") 
        Cells(sRow, "AD").Copy Destination:=DestSheet.Cells(dRow, "AD") 
        Cells(sRow, "AE").Copy Destination:=DestSheet.Cells(dRow, "AE") 
        Cells(sRow, "AF").Copy Destination:=DestSheet.Cells(dRow, "AF") 
        Cells(sRow, "AG").Copy Destination:=DestSheet.Cells(dRow, "AG") 
        Cells(sRow, "AH").Copy Destination:=DestSheet.Cells(dRow, "AH") 
        Cells(sRow, "AI").Copy Destination:=DestSheet.Cells(dRow, "AI") 
        Cells(sRow, "AJ").Copy Destination:=DestSheet.Cells(dRow, "AJ") 
        Cells(sRow, "AK").Copy Destination:=DestSheet.Cells(dRow, "AK") 
        Cells(sRow, "AL").Copy Destination:=DestSheet.Cells(dRow, "AL") 
        Cells(sRow, "AM").Copy Destination:=DestSheet.Cells(dRow, "AM") 


       End If 

       If Cells(sRow, "AD") Like "*x*" Then 

        sCount = sCount + 1 
        dRow = dRow + 1 
        'copy cols A,F,E & D 
        Cells(sRow, "A").Copy Destination:=DestSheet.Cells(dRow, "A") 
        Cells(sRow, "B").Copy Destination:=DestSheet.Cells(dRow, "B") 
        Cells(sRow, "C").Copy Destination:=DestSheet.Cells(dRow, "C") 
        Cells(sRow, "D").Copy Destination:=DestSheet.Cells(dRow, "D") 
        Cells(sRow, "E").Copy Destination:=DestSheet.Cells(dRow, "E") 
        Cells(sRow, "F").Copy Destination:=DestSheet.Cells(dRow, "F") 
        Cells(sRow, "G").Copy Destination:=DestSheet.Cells(dRow, "G") 
        Cells(sRow, "H").Copy Destination:=DestSheet.Cells(dRow, "H") 
        Cells(sRow, "I").Copy Destination:=DestSheet.Cells(dRow, "I") 
        Cells(sRow, "J").Copy Destination:=DestSheet.Cells(dRow, "J") 
        Cells(sRow, "K").Copy Destination:=DestSheet.Cells(dRow, "K") 
        Cells(sRow, "L").Copy Destination:=DestSheet.Cells(dRow, "L") 
        Cells(sRow, "M").Copy Destination:=DestSheet.Cells(dRow, "M") 
        Cells(sRow, "N").Copy Destination:=DestSheet.Cells(dRow, "N") 
        Cells(sRow, "O").Copy Destination:=DestSheet.Cells(dRow, "O") 
        Cells(sRow, "P").Copy Destination:=DestSheet.Cells(dRow, "P") 
        Cells(sRow, "Q").Copy Destination:=DestSheet.Cells(dRow, "Q") 
        Cells(sRow, "R").Copy Destination:=DestSheet.Cells(dRow, "R") 
        Cells(sRow, "S").Copy Destination:=DestSheet.Cells(dRow, "S") 
        Cells(sRow, "T").Copy Destination:=DestSheet.Cells(dRow, "T") 
        Cells(sRow, "U").Copy Destination:=DestSheet.Cells(dRow, "U") 
        Cells(sRow, "V").Copy Destination:=DestSheet.Cells(dRow, "V") 
        Cells(sRow, "W").Copy Destination:=DestSheet.Cells(dRow, "W") 
        Cells(sRow, "X").Copy Destination:=DestSheet.Cells(dRow, "X") 
        Cells(sRow, "Y").Copy Destination:=DestSheet.Cells(dRow, "Y") 
        Cells(sRow, "Z").Copy Destination:=DestSheet.Cells(dRow, "Z") 
        Cells(sRow, "AA").Copy Destination:=DestSheet.Cells(dRow, "AA") 
        Cells(sRow, "AB").Copy Destination:=DestSheet.Cells(dRow, "AB") 
        Cells(sRow, "AC").Copy Destination:=DestSheet.Cells(dRow, "AC") 
        Cells(sRow, "AD").Copy Destination:=DestSheet.Cells(dRow, "AD") 
        Cells(sRow, "AE").Copy Destination:=DestSheet.Cells(dRow, "AE") 
        Cells(sRow, "AF").Copy Destination:=DestSheet.Cells(dRow, "AF") 
        Cells(sRow, "AG").Copy Destination:=DestSheet.Cells(dRow, "AG") 
        Cells(sRow, "AH").Copy Destination:=DestSheet.Cells(dRow, "AH") 
        Cells(sRow, "AI").Copy Destination:=DestSheet.Cells(dRow, "AI") 
        Cells(sRow, "AJ").Copy Destination:=DestSheet.Cells(dRow, "AJ") 
        Cells(sRow, "AK").Copy Destination:=DestSheet.Cells(dRow, "AK") 
        Cells(sRow, "AL").Copy Destination:=DestSheet.Cells(dRow, "AL") 
        Cells(sRow, "AM").Copy Destination:=DestSheet.Cells(dRow, "AM") 



       End If 
      Next sRow 
    MsgBox sCount & " Rows Copied", vbInformation, "Transfer Done" 





End Sub

Source

2015-09-30 helloweenx

Y at-il une raison de ne pas utiliser 'cellules (sRow, "A") Redimensionner (1, 39) .copy Destination:. = DestSheet.Cells (drow, "A")' – Jeeped

Si vous copie complète lignes pourquoi ne pas utiliser 'DestSheet2.Rows (sRow) .Copy destination: = DestSheet.Rows (dRow)'? Btw votre code n'a pas incrémenter dRow dans le cas X, et vous pouvez factoriser les cas x et X. –

comme je l'ai dit, je suis vba newbie. Merci pour vos suggestions, va l'essayer et vous le faire savoir – helloweenx

Pour ma part, le code suivant fonctionne correctement, en supposant que les formes ne sont pas supérieures à une ligne.

Public Sub test() 
    Dim sRange As Range 
    Dim dst As Worksheet, src As Worksheet 
    Dim dRow As Long, sRow As Long, lastRow As Long 
    Dim sCount As Long 

    Set dst = Worksheets("odch.l.2") 'Destination worksheet 
    Set src = Worksheets("ot.2") 'Source worksheet 
    sRow = 1 'Starting source row 
    dRow = 16 'Starting destination row 
    lastRow = 12 'Last row to copy 

    Dim shp As Shape 
    'Ensure Shapes are moved with cells 
    For Each shp In src.Shapes 
     shp.Placement = xlMove 
    Next shp 

    sCount = 0 
    For sRow = sRow To lastRow 
    If Cells(sRow, 30) Like "*[Xx]*" Then 
     src.Rows(sRow).Select 'Select current and all linked rows 
     Selection.Copy Destination:=dst.Rows(dRow) 
     'lookup to copy shape 
     sCount = sCount + 1 'should it count as 1 or more? 
     dRow = dRow + Selection.Rows.Count ' Move down by the number of rows in the selection 
     sRow = sRow + Selection.Rows.Count - 1 'Skip the linked rows so that we don't duplicate them 
    End If 
    Next sRow 
    MsgBox sCount & " Rows Copied", vbInformation, "Transfer Done" 
    Set src = Nothing 
    Set dst = Nothing 

End Sub

Source

2015-09-30 10:01:20

fonctionne absolument grand homme, mais: -D il ya un problème avec certaines cellules fusionnées - est-il un moyen de copier des cellules avec des formes et avec la formation de la cellule? – helloweenx

déjà recherché la méthode "pastespecial" avec "Coller: = xlPasteFormats", malheureusement je suis noob et je ne suis pas vraiment sûr de l'implémenter dans le code ci-dessus, quand il n'y a pas "copier/coller" mais "copier sans coller" :-D quelqu'un s'il vous plaît? – helloweenx

Vos cellules fusionnées sont-elles réparties sur plusieurs lignes? –

Il n'y a pas assez d'informations fournies sur la nature, la position et la relation avec les lignes sur le Shape objects donc je devais faire quelques hypothèses.

Sub test150929() 
    Dim DestSheet  As Worksheet 
    Dim Destsheet2  As Worksheet 
    Dim sRow  As Long  'row index on source worksheet 
    Dim dRow  As Long  'row index on destination worksheet 
    Dim sCount  As Long 
    Dim Range_to As Integer 
    Dim Cell As String 
    Dim oneShape As Shape 
    Dim myLeft As Single, myTop As Single 
    Dim dSHAPEs As Object, vSHAPE As Variant 

    Application.ScreenUpdating = False 

    sCount = 0 
    dRow = 16 

    Set DestSheet = Worksheets("odch.l.2") 
    Set Destsheet2 = Worksheets("ot.2") 
    Set dSHAPEs = CreateObject("Scripting.Dictionary") 

    For Each oneShape In Destsheet2.Shapes 
     With oneShape 
      If Not dSHAPEs.exists(.Top) Then 
       dSHAPEs.Add Key:=.Top, Item:=Join(Array(.Name, .Top, .Left), Chr(124)) 
      End If 
     End With 
    Next oneShape 

    With Destsheet2 
     Range_to = .Range("AM12") 
     For sRow = 1 To Range_to 
      'use pattern matching to find "X" anywhere in cell 
      If LCase(.Cells(sRow, "AD").Value2) Like "*x*" Then 
       sCount = sCount + 1 
       dRow = dRow + 1 
       'copy cols A,F,E & D 
       .Cells(sRow, "A").Resize(1, 39).Copy Destination:=DestSheet.Cells(dRow, "A") 
       If dSHAPEs.exists(.Cells(sRow, "A").Top) Then 
        vSHAPE = Split(dSHAPEs.Item(.Cells(sRow, "A").Top), Chr(124)) 
        .Shapes(vSHAPE(0)).Copy 
        With DestSheet 
         .Paste 
         With .Shapes(.Shapes.Count) 
          .Top = .Parent.Cells(dRow, "A").Top 
          .Left = Destsheet2.Shapes(vSHAPE(0)).Left 
         End With 
        End With 
       End If 
      End If 
     Next sRow 
    End With 
    MsgBox sCount & " Rows Copied", vbInformation, "Transfer Done" 

End Sub

J'ai créé un dictionnaire de la dimension .Top pour chaque forme de la feuille de calcul source. Un dictionnaire utilise un index unique, donc la méthode que j'ai choisie pour identifier les objets dans le Shapes Collection ne fonctionnera pas si a) les formes ont un .Top différent des lignes avec lesquelles elles doivent être copiées et b) il y en a plusieurs forme à copier pour chaque rangée. Cela dit, le cadre est solide et testé. Si cela ne fonctionne pas pour vous, vous pouvez peut-être ajuster la méthode car vous avez plus de détails à votre disposition sur les formes. Vous devrez peut-être collecter les formes et leurs propriétés différemment, puis parcourir chaque forme pour chaque ligne copiée et voir si elle doit être copiée avec la ligne. C'est juste de la spéculation mais je vole aveuglément aussi loin que les formes vont.

Source

2015-09-30 09:30:19 Jeeped

excel vba - copier/coller ligne spécifique à une autre feuille avec toutes sortes de formes si les conditions sont remplies

Répondre

Questions connexes