![](/img/trans.png)
[英]How do I copy all rows with a specific value in one of their columns to another spreadsheet?
[英]How do I copy to another worksheet specific columns and rows
我有一个工作表,其中包含A:M列和1至5000行。当L和M列的数字大于0时,我想将行复制到另一个工作表。我也只需要A:F和K:M列在新的工作表上
您需要命名源和目标工作表,但是下面的代码应该可以解决问题。
Sub SheetTransfer()
Dim i As Long
Dim j As Long
Dim t As Double
Dim LastRow As Long
Dim ws1 As String
Dim ws2 As String
'name source worksheet here
ws1 = "Sheet1"
'name target worksheet here
ws2 = "Sheet2"
'set the threshold value for a row to be copied over
t = 0
' set to column L
j = 12
For i = 1 To 5000
If Worksheets(ws1).Cells(i, j).Value > 0 Or Cells(i, j + 1).Value > t Then
'find last row of target worksheet
With Worksheets(ws2)
LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
End With
'copy/paste columns A-F
Worksheets(ws1).Range(Cells(i, 1), Cells(i, 6)).Copy
Worksheets(ws2).Cells(LastRow + 1, 1).PasteSpecial xlPasteValues
'copy paste columns K-M
Worksheets(ws1).Range(Cells(i, 11), Cells(i, 13)).Copy
Worksheets(ws2).Cells(LastRow + 1, 11).PasteSpecial xlPasteValues
End If
Next i
End Sub
调整常量部分中的值以适合您的需求。
Sub AM5000()
' Source
Const cVntSource As Variant = "Sheet1" ' Source Worksheet Name/Index
Const cStrRange1 As String = "A1:F5000" ' Source 1 Range Address
Const cStrRange2 As String = "K1:M5000" ' Source 2 Range Address
Const cIntCol1 As Integer = 2 ' Source Range Criteria Column 1
Const cIntCol2 As Integer = 3 ' Source Range Criteria Column 2
' Target
Const cVntTarget As Variant = "Sheet2" ' Target Worksheet Name/Index
Const cStrTarget As String = "A1" ' Target First Cell Address
Dim vnt1 As Variant ' Source 1 Array
Dim vnt2 As Variant ' Source 2 Array
Dim vntTarget As Variant ' Target Array
Dim i As Integer ' Source Arrays Row Counter
Dim j As Integer ' Arrays Column Counter
Dim k As Integer ' Target Array Row Counter
' Paste Source Ranges into Source Arrays.
With Worksheets(cVntSource)
vnt1 = .Range(cStrRange1)
vnt2 = .Range(cStrRange2)
End With
' Count the number of rows for Target Array.
For i = 1 To UBound(vnt2)
If vnt2(i, cIntCol1) > 0 And vnt2(i, cIntCol2) > 0 Then
k = k + 1
End If
Next
' Write Source Arrays to Target Array.
ReDim vntTarget(1 To k, 1 To UBound(vnt1, 2) + UBound(vnt2, 2))
k = 0
For i = 1 To UBound(vnt2)
If vnt2(i, cIntCol1) > 0 And vnt2(i, cIntCol2) > 0 Then
k = k + 1
For j = 1 To UBound(vnt1, 2)
vntTarget(k, j) = vnt1(i, j)
Next
For j = 1 To UBound(vnt2, 2)
vntTarget(k, j + UBound(vnt1, 2)) = vnt2(i, j)
Next
End If
Next
' Paste Target Array into Target Range.
With Worksheets(cVntTarget).Range(cStrTarget)
'.Parent.Cells.ClearContents
.Resize(UBound(vntTarget), UBound(vntTarget, 2)) = vntTarget
End With
End Sub
声明:本站的技术帖子网页,遵循CC BY-SA 4.0协议,如果您需要转载,请注明本站网址或者原文地址。任何问题请咨询:yoyou2525@163.com.