excel vba-如果满足条件,则将特定于excel vba的行复制/粘贴到具有各种形状的其他图纸
我有非常具体的情况。如果表格1(ot.2)中的列“AD”在单元格“NOK”中标记“x”或“x”,我需要将该行的每一行复制到表格2(odch.l.2)。形状必须与数据保持一致 到目前为止,我成功地复制了所有形状,无论是否有x或x,而数据取决于是否有x或x-但数据和形状并没有粘在一起-数据被一个接一个地排序,形状在源工作表中按位置复制 我不知道如何进行,我是这件事的新手,我将感谢每一种帮助 如果你需要更多的信息,请告诉我,我会一直看这个帖子:-D谢谢 这是我的密码:excel vba-如果满足条件,则将特定于excel vba的行复制/粘贴到具有各种形状的其他图纸,vba,excel,conditional-statements,excel-2003,Vba,Excel,Conditional Statements,Excel 2003,我有非常具体的情况。如果表格1(ot.2)中的列“AD”在单元格“NOK”中标记“x”或“x”,我需要将该行的每一行复制到表格2(odch.l.2)。形状必须与数据保持一致 到目前为止,我成功地复制了所有形状,无论是否有x或x,而数据取决于是否有x或x-但数据和形状并没有粘在一起-数据被一个接一个地排序,形状在源工作表中按位置复制 我不知道如何进行,我是这件事的新手,我将感谢每一种帮助 如果你需要更多的信息,请告诉我,我会一直看这个帖子:-D谢谢 这是我的密码: Sub test150929(
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
由于没有提供足够的关于属性、位置以及与上的行的关系的信息,因此我不得不做出一些假设
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)每行有多个要复制的形状,则我选择的用于标识中对象的方法将不起作用
话虽如此,该框架是健全的,经过测试。如果这对您不起作用,也许您可以调整该方法,因为您可以获得有关形状的更多详细信息。您可能需要以不同的方式收集形状及其属性,然后针对每个复制的行遍历每个形状,并查看是否应将其与该行一起复制。这只是猜测,但就形状而言,我是盲目的。没有提供足够的信息来说明图形的性质、位置以及与行的关系,因此我不得不做出一些假设
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)每行有多个要复制的形状,则我选择的用于标识中对象的方法将不起作用
话虽如此,该框架是健全的,经过测试。如果这对您不起作用,也许您可以调整该方法,因为您可以获得有关形状的更多详细信息。您可能需要以不同的方式收集形状及其属性,然后针对每个复制的行遍历每个形状,并查看是否应将其与该行一起复制。这只是猜测,但对于形状而言,我是盲目的。对于我来说,假设形状不高于一行,下面的代码工作正常
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
就我而言,假设形状不高于一行,下面的代码工作正常
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
不使用
单元格(sRow,“a”)。调整大小(1,39)。复制目标:=DestSheet.Cells(dRow,“a”)
如果复制整行,为什么不使用DestSheet2.rows(sRow)。复制目标:=DestSheet.rows(dRow)
?顺便说一句,你的代码在X案例中没有增加dRow,你可以考虑X和X案例。正如我说的,伙计们,我是vba新手。谢谢你的建议,我会尝试一下,让你知道同意@VincentG-我是按照的思路思考的,如果LCase(.Cells(sRow,“AD”).Value2)像“*x*”那么.a)形状的.Top
与行具有相同的.Top
?b) 每行是否有多个形状需要复制?是否有理由不使用单元格(sRow,“a”)。调整大小(1,39)。复制目标:=DestSheet.Cells(dRow,“a”)
如果复制整行,为什么不使用DestSheet2.rows(sRow)。复制目标:=DestSheet.rows(dRow)
?顺便说一句,你的代码在X案例中没有增加dRow,你可以考虑X和X案例。正如我说的,伙计们,我是vba新手。谢谢你的建议,我会尝试一下,让你知道同意@VincentG-我是按照的思路思考的,如果LCase(.Cells(sRow,“AD”).Value2)像“*x*”那么.a)形状的.Top
与行具有相同的.Top
?b) 每行有多个要复制的形状吗?这绝对是一个伟大的人,但是:-D一些合并的单元格有问题-有没有办法复制带有形状的单元格以及单元格的格式?已经查找了带有“Paste:=xlPasteFormats”的方法“pastespecial”,可悲的是,我是noob,我真的不知道如何在上面的代码中实现它,当没有“复制/粘贴”而是“复制而不粘贴”:-D有人吗?您的合并单元格是在多行上吗?因为您复制的是整行,所以合并列应该不会有问题,但合并行可能会有问题。我看到的唯一解决方法是选择行,因为它将选择由合并单元格链接的所有行。查看我的最新答案。可能我做错了什么,但它不起作用。数据和形状仍然以与以前相同的方式复制。行上的合并单元格并没有被复制,这绝对是一个伟大的人,但是:-D一些合并单元格有问题-有没有办法复制带有形状的单元格以及单元格的格式?已经查找了带有“粘贴:=xlPasteFormats”的方法“pastespecial”,很遗憾,我不知道如何在上面的代码中实现它,如果不是“复制/粘贴”而是“复制而不粘贴”:-D有人吗?合并的单元格是否超过多行?由于您复制的是整行,合并的列应该不会有问题,但合并的行可能会有问题。我看到的唯一解决方法是选择行,因为它将选择由合并单元格链接的所有行。查看我的最新答案。可能我做错了什么,但它不起作用。数据和形状仍然以与以前相同的方式复制。行上的合并cel根本不被复制