excel vba-如果满足条件，则将具有各种形状的特定行复制/粘贴到另一张表

Question

i have pretty specific situation. i need to copy every row from sheet1 (ot.2) to sheet2 (odch.l.2) if column "AD" in that row have in cell "NOK" mark "x" or "X". Shapes must stay with data.

so far i managed to copy all shapes no matter if there is x or X, while data depends if there is x or X - BUT data and shapes are not sticked together - data are sorted right after another, and shapes are copied by position in source sheet

i have no idea how to proceed, i am newbie in this matter and i would appreciate every kind of help.

if you gonna need some more info, please let me know, i am gonna watch this thread all the time :-D thanks

here is my 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

Answer 1

There isn't enough information provided on the nature, position and relationship to the rows on the Shape objects so I had to make a few assumptions.

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

I've created a dictionary of the .Top dimension for each shape on the source worksheet. A dictionary uses a unique index, so the method I've chosen to identify the objects in the Shapes Collection will not work if a) the shapes have a different .Top than the rows they are to copied with and b) there are more than a single shape to be copied for each row.

With that said, the framework is sound and tested. If this is not working for you, perhaps you can adjust the method as you have more details available to you about the shapes. You might have to collect the shapes and their properties differently and then loop through each shape for every copied row and see if it should be copied along with the row. That's just speculation but I'm flying blind as far as the shapes go.

Answer 2

For my part the following code is working fine, assuming that the shapes are not higher than a row.

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