excel vba-如果滿足條件，則將具有各種形狀的特定行復制/粘貼到另一張表

Question

我有非常具體的情況。 如果該行中的列“ AD”在單元格“ NOK”中標記為“ x”或“ X”，則我需要將每一行從sheet1（ot.2）復制到sheet2（odch.l.2）。 形狀必須與數據保持一致。

到目前為止，我設法復制了所有形狀，無論是否存在x或X，而數據取決於是否存在x或X-但是數據和形狀沒有粘在一起-數據緊挨着排序，形狀按位置復制資料表

我不知道如何進行，在這件事上我是新手，我將不勝感激。

如果您需要更多信息，請讓我知道，我將一直一直在關注此主題：-D謝謝

這是我的代碼：

 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

沒有提供足夠的有關Shape對象上行的性質，位置和關系的信息，因此我不得不作一些假設。

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

我為源工作表上的每個形狀創建了.Top維度的字典。 字典使用唯一索引，因此，如果a）形狀與要復制的行的.Top不同，並且b）的形狀大於a，則我選擇的用於識別Shapes Collection中對象的方法將不起作用。每行要復制一個形狀。

話雖如此，該框架是完善且經過測試的。 如果這不適合您，也許您可​​以調整方法，因為您可以獲得有關形狀的更多詳細信息。 您可能必須以不同的方式收集形狀及其屬性，然后遍歷每個復制行的每個形狀，並查看是否應隨行一起復制它。 那只是猜測，但就形狀而言，我一直處於盲目狀態。

Answer 2

就我而言，假設形狀不高於一行，下面的代碼可以正常工作。

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