我有一个工作表,其中包含A:M列和1至5000行。当L和M列的数字大于0时,我想将行复制到另一个工作表。我也只需要A:F和K:M列在新的工作表上
you'll need to name the source and target worksheets, but below code should do the trick.
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
Adjust the values in the constants section to fit your needs.
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
The technical post webpages of this site follow the CC BY-SA 4.0 protocol. If you need to reprint, please indicate the site URL or the original address.Any question please contact:yoyou2525@163.com.