excel vba – 如果满足条件，则将特定的复制/粘贴行粘贴到具有各种形状的另一张纸上
我有相当具体的情况。 如果该行的“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 对于我来说，下面的代码工作正常，假设形状不是高于一行。
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
没有提供有关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
我已经为源工作表中的每个形状创build了.Top尺寸的字典。 一个字典使用一个唯一的索引，所以我select的识别Shapes集合中的对象的方法将不起作用，如果a）形状有一个不同的.Top比他们要复制的行和b）有多个为每一行复制一个单一的形状。
这样说，框架是健全的，经过testing。 如果这不适合你，也许你可以调整方法，因为你有更多关于形状的细节。 您可能必须以不同的方式收集形状及其属性，然后遍历每个复制行的每个形状，并查看是否应该与该行一起复制。 这只是猜测，但是就形状而言，我是盲目的。