opening workbook after searching for a string

Question

a little understanding before i explain what this code is about, first the user will open a empty microsoft excel, and then the user will on a macro to open multiple workbook into the current active excel, for example, if the user chose to open "book1" and "book2" together, the current active excel will open them and split them into a new sheet named after the workbook it was currently named, example sheet "book1" and sheet "book2".

so basically this program enables user to search for a string(in all the sheets), and then after finding out where the string is, it copies the entire row + header to a new sheet named after the searching string.

For example, if i search for apple, it will copy the entire row consists of the word " apple " and paste into a new sheet named "apple" and the row and header will be copied over there, what i need to do now is to create a new workbook and create a new sheet named after the search string AND the workbook it was previously named.

Like i said, i've opened workbook "book1" and "book2", and if the searched word is from sheet "book1", the macro will copy the searched string into a new workbook, a new sheet named "book1" with the information.

i know i had explained this in a very wordy way, let me know if you need any clarification.

    Private Sub CommandButton5_Click()
   Dim i As Long, nRowsAddePerSheet As Long, nRows As Long, _
    nRowsMax As Long, nSheets As Long
  Dim strSearch, strSearch2
  Dim rg As Range, rgF As Range
  Dim wks
  Dim x

  strSearch = Application.InputBox("Please enter the search string")
  strSearch2 = Replace(strSearch, "*", "")
  If Len(strSearch2) <= 0 Then
    MsgBox "ABandon: Search string must not be empty."
    Exit Sub
  End If

  Application.ScreenUpdating = False

  nSheets = Sheets.Count
  nRowsMax = ActiveSheet.Rows.Count

  For x = 1 To nSheets

    On Error Resume Next
    Set wks = Worksheets(strSearch2)
    If (Err) Then
      Set wks = Worksheets.Add(After:=Sheets(Sheets.Count))
      wks.Name = strSearch2
      Err.Clear
    End If
    On Error GoTo 0

    Sheets(x).Activate
    Set rg = ActiveSheet.Cells(1).CurrentRegion

    nRows = rg.Rows.Count
    nRowsAddePerSheet = 0
    For i = 1 To nRows
      Set rgF = rg.Rows(i).Find(strSearch, , xlValues, xlWhole)

      If Not rgF Is Nothing Then

        If (nRowsAddePerSheet <= 0) Then
          If (i <> 1) Then
            rg.Rows(1).Copy wks.Range("A" & nRowsMax).End(xlUp).Offset(1, 0)
          End If
        End If

        rg.Rows(i).Copy wks.Range("A" & nRowsMax).End(xlUp).Offset(1, 0)
        nRowsAddePerSheet = nRowsAddePerSheet + 1
      End If
    Next
  Next

  Set rgF = Nothing
  Set rg = Nothing
  Set wks = Nothing

  Application.ScreenUpdating = True

End Sub

Answer 1

Is this what you are trying?

Followup from comments: The idea is to save the file and then check if that file exists or not. If it exists then find the last row and then input the data there. Option Explicit

Dim HeaderExists As Boolean

Sub Sample()
    Dim wb As Workbook, wbNew As Workbook
    Dim ws As Worksheet, wsNew As Worksheet
    Dim strSearch As String
    Dim aCell As Range, bCell As Range
    Dim LRow As Long, nCol As Long

    strSearch = Application.InputBox("Please enter the search string")

    If strSearch = "" Then
        MsgBox "ABandon: Search string must not be empty."
        Exit Sub
    End If

    '~~> Check if a workbook with the name already exists
    For Each wb In Application.Workbooks
        If InStr(1, wb.Name, strSearch & ".xl", vbTextCompare) Then
            Set wbNew = wb
            On Error Resume Next
            Set wsNew = wbNew.Sheets(strSearch)
            On Error GoTo 0
            Exit For
        End If
    Next

    If Not wsNew Is Nothing Then
        If Application.WorksheetFunction.CountA(wsNew.Cells) <> 0 Then
            HeaderExists = True
            LRow = wsNew.Cells.Find(What:="*", _
                    After:=wsNew.Range("A1"), _
                    Lookat:=xlPart, _
                    LookIn:=xlFormulas, _
                    SearchOrder:=xlByRows, _
                    SearchDirection:=xlPrevious, _
                    MatchCase:=False).Row + 1

        End If
    End If

    '~~> Add the new workbook
    If wbNew Is Nothing Then
        Set wbNew = Workbooks.Add
        wbNew.SaveAs "C:\" & strSearch & ".xls", FileFormat:=56
        Set wsNew = wbNew.Sheets(1)
        wsNew.Name = strSearch
    End If

    If LRow = 0 Then LRow = 1

    '~~> Loop through all workbooks and worksheets to find the word
    For Each wb In Application.Workbooks
        If wb.Name <> wbNew.Name Then
            For Each ws In wb.Worksheets
                Set aCell = ws.Cells.Find(What:=strSearch, LookIn:=xlValues, _
                    Lookat:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
                    MatchCase:=False, SearchFormat:=False)

                If Not aCell Is Nothing Then
                    Set bCell = aCell

                    nCol = aCell.Row

                    If HeaderExists = False Then
                        ws.Rows(1).Copy wsNew.Rows(1)
                        LRow = LRow + 1
                    End If


                    ws.Rows(aCell.Row).Copy wbNew.Sheets(1).Rows(LRow)

                    LRow = LRow + 1

                    Do
                        Set aCell = ws.Cells.FindNext(After:=aCell)

                        If Not aCell Is Nothing Then
                            If aCell.Address = bCell.Address Then Exit Do

                            If nCol <> aCell.Row Then
                                ws.Rows(aCell.Row).Copy wsNew.Rows(LRow)
                                LRow = LRow + 1
                            End If
                        Else
                            Exit Do
                        End If
                    Loop
                End If
            Next
        End If
    Next
End Sub