поиск найти совпадения и скопировать диапазон строк на другой лист

Question

Лист (LIST2) имеет 8 столбцов. Столбец A листа (LIST2) содержит номера идентификаторов. Идентификационный номер идентификатора повторяется много раз во многих строках столбца A. В столбцах с B по H содержатся другие данные. В листах (Sheet1) A1 мы вводим идентификационный номер, который находит совпадения в столбце A Sheets (LIST2), и копируем каждую математическую строку из A в H

.

Я нашел код для копирования всех строк, но мне нужны только строки от A до H

Sub SearchForString ()

Dim LCopyToRow As Integer


On Error GoTo Err_Execute


'Start copying data to row 2 in Sheet2 (row counter variable)
LCopyToRow = 3

Dim sheetTarget As String: sheetTarget = "sheet1"
Dim sheetToSearch As String: sheetToSearch = "LIST2"
Dim targetValue As String: targetValue = Sheets(sheetTarget).Range("A1").Value  'Value in sheet2!A1 to be searched in sheet1
Dim columnToSearch As String: columnToSearch = "A"
Dim iniRowToSearch As Integer: iniRowToSearch = 2
Dim LSearchRow As Long 'As far as it is not clear the number of rows you will be considering, better relying on the long type
Dim maxRowToSearch As Long: maxRowToSearch = 2000 'There are lots of rows, so better setting a max. limit

If (Not IsEmpty(targetValue)) Then
    For LSearchRow = iniRowToSearch To Sheets(sheetToSearch).Rows.Count

        'If value in the current row (in columnToSearch in sheetToSearch) equals targetValue, copy entire row to LCopyToRow in sheetTarget
        If Sheets(sheetToSearch).Range(columnToSearch & CStr(LSearchRow)).Value = targetValue Then

            'Select row in Sheet1 to copy
            Sheets(sheetToSearch).Rows(LSearchRow).Copy

            'Paste row into Sheet2 in next row
            Sheets(sheetTarget).Rows(LCopyToRow).PasteSpecial Paste:=xlPasteValues
            Sheets(sheetTarget).Rows(LCopyToRow).PasteSpecial Paste:=xlFormats
            'Move counter to next row
            LCopyToRow = LCopyToRow + 1
        End If

        If (LSearchRow >= maxRowToSearch) Then
            Exit For
        End If

    Next LSearchRow

    'Position on cell A3
    Application.CutCopyMode = False
    Range("A3").Select


End If

Exit Sub

Err_Execute:

End Sub

Мне нравится копировать и вставлять каждую строку из столбца A в столбец H

Answer 1

Вам нужно изменить диапазон, который вы копируете, поэтому вместо копирования полной строки вам нужно просто скопировать нужные столбцы

Не могли бы вы попробовать с этими строками?

Sheets(sheetToSearch).Range("a" & LSearchRow, "h" & LSearchRow).Copy
'Paste row into Sheet2 in next row
Sheets(sheetTarget).Range("a" & LCopyToRow).PasteSpecial Paste:=xlPasteValues
Sheets(sheetTarget).Range("a" & LCopyToRow).PasteSpecial Paste:=xlFormats

Дляизбегая перезаписи "A3" при изменении "ID", не могли бы вы попробовать заменить начало "sub" этим?

Sub matchandcopy()

Dim LCopyToRow As Integer
Dim sheetTarget As String: sheetTarget = "sheet1"
Dim sheetToSearch As String: sheetToSearch = "LIST2"
Dim targetValue As String: targetValue = Sheets(sheetTarget).Range("A1").Value  'Value in sheet2!A1 to be searched in sheet1
Dim columnToSearch As String: columnToSearch = "A"
Dim iniRowToSearch As Integer: iniRowToSearch = 2
Dim LSearchRow As Long 'As far as it is not clear the number of rows you will be considering, better relying on the long type
Dim maxRowToSearch As Long: maxRowToSearch = 2000 'There are lots of rows, so better setting a max. limit


LCopyToRow = Sheets(sheetTarget).Range("a1").End(xlDown).Row + 1
If LCopyToRow > 100000 Then LCopyToRow = 3

If (Not IsEmpty(targetValue)) Then 'here goes the rest of the sub with no changes  ....