Цикл от ограничения содержимого на листе для соответствия и копирования в VBA Excel

Question

Я новичок здесь, и это моя проблема; в VBA, Excel 2010 я хочу найти конкретное c слово или список слов в каждой строке с содержимым на одном листе, и если он совпадает, то он копирует всю строку этого листа и вставляет его в новый в первая строка, а затем продолжается цикл назад и вперед от листа к листу после окончания списка слов. В конце вы получите новый лист с кучей строк, собранных из вашего поискового запроса. У меня есть исходный код, не знаю, понравится ли вам, ребята, его увидеть. Спасибо.

Sub Macro1()
    Dim sheetName As String
    Dim recintos As String
    Dim recintosArray() As String
    Dim namevar As Variant
    Dim sheetLimit As Integer
    Dim n As Integer

    'Words to search and copy in the sheet 
    'Nombre del sheet a buscar en el documento abierto
    sheetName = InputBox("Nombre de la hoja o sheet en donde desea copiar los recintos :")

    'Save a string type data 
    'Guarda los datos como tipo cadena
    recintos = InputBox("Introduzca los nombres  de los recintos separados por coma :", "Buscador de recintos", "00000,00000,00000...")

    'Split the words and save it in array type 
    'Separa la cadena y los guarda en un arreglo
    recintosArray() = Split(recintos, ",")
    namevar = InputBox("Introduzca el nombre de la hoja que desea crear para pegar c/u :")

    'Makes a new sheet and defines a name
    'Crea un sheet nuevo y define el nombre
    Sheets.Add After:=Sheets(Sheets.Count)
    Sheets(Sheets.Count).Name = namevar
    sheetLimit = Sheets(sheetName).Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Row

    'Array index
    'Indice del arreglo recintosArray
    n = 0

    For i = 1 To sheetLimit
        Sheets(sheetName).Activate
        currentCellName = Sheets(sheetName).Cells(i, 1).Value

        If n <= UBound(recintosArray) Then
            If Replace(currentCellName, Chr(32), "") = recintosArray(n) Then
                Sheets(sheetName).Rows(i).Copy
                newSheetLimit = Sheets(namevar).Cells(Rows.Count, 1).End(xlUp).Offset(0, 0).Row
                Sheets(namevar).Activate
                Sheets(namevar).Cells(newSheetLimit + 1, 1).Select
                ActiveSheet.Paste
                n = n + 1
                i = 1
            End If
        End If
    Next i
End Sub

Answer 1

Вы можете прочитать комментарии к коду и настроить его в соответствии со своими потребностями

Не забудьте использовать F8 jey, чтобы пройти по нему

Были некоторые части вашего кода, которые я не смог ' t полностью понимает

РЕДАКТИРОВАТЬ: Добавлена ​​недостающая функция

РЕДАКТИРОВАТЬ2: Копировать всю строку

Код

Public Sub Macro2()

    Dim sourceSheet As Worksheet
    Dim targetSheet As Worksheet

    Dim sourceRange As Range
    Dim cell As Range

    Dim sourceSheetName As String
    Dim targetSheetName As String

    Dim recintos As String
    Dim recintosArray As Variant

    Dim lastRow As Long
    Dim targetRow As Long

    ' Set the starting row in which the cells are going to be copied
    targetRow = 1

    'Words to search and copy in the sheet
    'Nombre del sheet a buscar en el documento abierto
    sourceSheetName = InputBox("Nombre de la hoja o sheet en donde desea copiar los recintos :")
    Set sourceSheet = ThisWorkbook.Worksheets(sourceSheetName)

    'Save a string type data
    'Guarda los datos como tipo cadena
    recintos = InputBox("Introduzca los nombres  de los recintos separados por coma :", "Buscador de recintos", "00000,00000,00000...")

    'Nombre del sheet a crear
    targetSheetName = InputBox("Introduzca el nombre de la hoja que desea crear para pegar c/u :")

    'Split the words and save it in array type
    'Separa la cadena y los guarda en un arreglo
    recintosArray = Split(recintos, ",")

    ' You may want to check if user entered an array here

    ' Add a new sheet and set the reference
    Set targetSheet = ThisWorkbook.Worksheets.Add
    ' You may want to check here that the sheet doesn't exists...
    targetSheet.Name = targetSheetName

    ' Get the last row in column A
    lastRow = sourceSheet.Cells(sourceSheet.Rows.Count, 1).End(xlUp).Row

    ' Set the range where you want to look up the values
    Set sourceRange = sourceSheet.Range("A1:A" & lastRow)

    ' Loop through the column A values begining in row 1
    For Each cell In sourceRange.Cells

        ' Check if value is in array
        If IsInArray(cell.Value, recintosArray) Then
            targetSheet.Range("A" & targetRow).EntireRow.Value = cell.EntireRow.Value
            targetRow = targetRow + 1
        End If

    Next cell


End Sub

Public Function IsInArray(stringToBeFound As String, arr As Variant) As Boolean
    ' Credits: https://stackoverflow.com/a/11112305/1521579
    IsInArray = (UBound(Filter(arr, stringToBeFound)) > -1)
End Function

Дайте мне знать, если это работает