查找符合多个条件的单元格，并将其剪切粘贴到另一个工作表(简化)
查找符合多个条件的单元格，并将其剪切粘贴到另一个工作表(简化)
提问于 2017-01-28 22:27:33
任何替代方案或建议，以固定下面陈述的代码，找到多个条件的单元格，并剪切粘贴到另一个工作表。
Sub test()
'For Move Entire Row to New Worksheet if Cell Contains Specific Text's
'Using autofilter to Copy rows that contain certain text to a sheet called commodity
Dim LR As Long
Range("A2").EntireRow.Insert Shift:=xlDown
LR = Sheets("Data").Cells(Rows.Count, "E").End(xlUp).Row
LR1 = Sheets("Commodity").Cells(Rows.Count, "A").End(xlUp).Row + 1
With Sheets("Data").Range("e:e")
.AutoFilter Field:=1, Criteria1:=("*SILVER*")
.SpecialCells(xlCellTypeVisible).EntireRow.Copy
Destination:=Sheets("Commodity").Range("A" & LR1)
.SpecialCells(xlCellTypeVisible).EntireRow.Delete
End With
With Sheets("Data").Range("e:e")
.AutoFilter Field:=1, Criteria1:=("*GOLD*")
.SpecialCells(xlCellTypeVisible).EntireRow.Copy
Destination:=Sheets("Commodity").Range("A" & LR1)
.SpecialCells(xlCellTypeVisible).EntireRow.Delete
End With
With Sheets("Data").Range("e:e")
.AutoFilter Field:=1, Criteria1:=("*MCX*")
.SpecialCells(xlCellTypeVisible).EntireRow.Copy
Destination:=Sheets("Commodity").Range("A" & LR1)
.SpecialCells(xlCellTypeVisible).EntireRow.Delete
End With
End Sub回答 1
Stack Overflow用户
发布于 2017-01-30 10:13:49
除了@ShaiRado提出的好建议之外，让这一切变慢的是你与Excel函数和界面的重复交互。理想情况下，您应该将数据读取到VBA中的变量中，然后在VBA中检查匹配并准备输出数组。这样，您就只需要在VBA和Excel之间进行一次交互，即将输出数组写入目标工作表。一次删除一行的时间开销也很大，所以你最好只创建一个“删除范围”，然后一次完成所有的删除。
下面给出了实现这一点的框架代码(但请注意，如果您使用的范围不是从"A“开始的，则需要计算”列偏移量“，并且您可能会选择比UsedRange更可靠的函数)。您可以这样调用该例程：
TransferData "Silver", "Gold", "MCX"而例程本身可能类似于以下内容：
Private Sub TransferData(ParamArray searchItems() As Variant)
Dim srcData As Variant
Dim txData() As Variant
Dim item As Variant
Dim r As Long, c As Long
Dim txIndexes As Collection
Dim delRng As Range
'Read source data into an array
'Note: I've used UsedRange as I don't know your sheet layout
srcData = ThisWorkbook.Worksheets("Data").UsedRange.Value2
'Check for matches and record index number
Set txIndexes = New Collection
For r = 1 To UBound(srcData, 1)
For Each item In searchItems
If srcData(r, 5) = item Then
txIndexes.Add r
Exit For
End If
Next
Next
'Trasfer data to output array
ReDim txData(1 To txIndexes.Count, 1 To UBound(srcData, 2))
r = 1
For Each item In txIndexes
For c = 1 To UBound(srcData, 2)
txData(r, c) = srcData(item, c)
Next
r = r + 1
Next
'Write the transfer data to target sheet
With ThisWorkbook.Worksheets("Commodity")
.Cells(.Rows.Count, "A").End(xlUp).Resize(UBound(txData, 1), UBound(txData, 2)) = txData
End With
'Delete the transfered rows
For Each item In txIndexes
With ThisWorkbook.Worksheets("Data")
If delRng Is Nothing Then
Set delRng = .Cells(item, "A")
Else
Set delRng = Union(delRng, .Cells(item, "A"))
End If
End With
Next
If Not delRng Is Nothing Then delRng.EntireRow.Delete
End Sub页面原文内容由Stack Overflow提供。腾讯云小微IT领域专用引擎提供翻译支持
原文链接：
https://stackoverflow.com/questions/41910903
复制相关文章
相似问题
腾讯云开发者
