Как скопировать на другой лист конкретные столбцы и строки

Question

У меня есть лист со столбцами A: M и строками от 1 до 5000. Я хотел бы скопировать строки на другой лист, когда в столбцы L и M добавлено число больше 0. Мне также нужны только столбцы A: F и К: М на новом листе

Answer 1

Копирование данных на другой лист

Настройте значения в разделе констант в соответствии со своими потребностями.

Код

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

Answer 2

вам нужно будет назвать исходную и целевую таблицы, но приведенный ниже код должен помочь.

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