excel vba - 如果满足条件，特定的 copy/paste 行到另一个 sheet 具有各种形状

Question

我的情况很具体。我需要将每一行从 sheet1 (ot.2) 复制到 sheet2 (odch.l.2) 如果该行中的列 "AD" 在单元格 [=26 中=] 标记 "x" 或 "X"。形状必须与数据保持一致。

到目前为止，无论是否有 x 或 X，我都设法复制了所有形状，而数据取决于是否有 x 或 X - 但数据和形状没有粘在一起 - 数据一个接一个地排序，形状按源中的位置复制 sheet

我不知道如何进行，我是这方面的新手，我将不胜感激各种帮助。

如果您需要更多信息，请告诉我，我会一直关注这个话题:-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 objects 上行的性质、位置和关系的信息不足，因此我不得不做出一些假设。

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) 每行要复制的形状不止一个。

话虽如此，该框架是可靠的并且经过测试。如果这对您不起作用，也许您可以调整方法，因为您有更多关于形状的详细信息。您可能必须以不同方式收集形状及其属性，然后循环遍历每个复制行的每个形状，看看它是否应该与该行一起复制。这只是猜测，但就形状而言，我是盲目的。

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

excel vba - 如果满足条件，特定的 copy/paste 行到另一个 sheet 具有各种形状

excel vba - specific copy/paste row to another sheet with all kind of shapes if conditions are met

excel

vba

excel-2003

conditional-statements