Expand selection based on cell value and split the expanded selection into a separate file - excel

Question

I've been struggling with this for a while now.
A1:O7 are frozen columns.
Only the Column A contains trigger values that I find using
Dim Cell As Range
Columns("A:A").Select
Set Cell = Selection.Find(What:="BANK:", After:=ActiveCell, LookIn:=xlFormulas, _
LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
MatchCase:=True, SearchFormat:=False)
After that I need to expand the selection so that all the rows and the columns to the right and down from the cell found until the next cell to be found are copied and split into a separate file along with the frozen columns A1:O7 at the top. The range is A7:Oxxxx. There is no data beyond the O column.
Is there a solution to this without using any Excel add-ons?

Answer 1

I tried to understand the task. There are some information missing so this solution might not exactly fitting your needs. I hope it will work for you.
Private Sub Bank()
Dim ws As Worksheet
Set ws = ThisWorkbook.Worksheets("Bank") 'change according to your workingsheet
Dim rngHeader As Range
Set rngHeader = ws.Range("A1:O7")
Dim iWidth As Integer 'Data and header width
iWidth = rngHeader.Columns.Count
Dim strSearchText As String
strSearchText = "BANK:"
Dim rngSearchArea As Range
Set rngSearchArea = ws.Range(Range("A7"), ws.Range("A" & ws.Range("A:A").Cells.Count).End(xlUp))
Dim strFirstFound As String
Dim rngCurrentFound As Range
Set rngCurrentFound = ws.Range("A7")
Set rngCurrentFound = rngSearchArea.Find(What:=strSearchText, After:=rngCurrentFound, LookIn:=xlFormulas, _
LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
MatchCase:=True, SearchFormat:=False)
If rngCurrentFound Is Nothing Then
MsgBox "Nothing found"
Exit Sub
End If
strFirstFound = rngCurrentFound.Address
Dim rngSource As Range
Dim rngNextFound As Range
Do
'Get the position of the next occurence to set the end position
Set rngNextFound = rngSearchArea.FindNext(rngCurrentFound)
If rngNextFound.Row > rngCurrentFound.Row Then
'There is next one
Set rngSource = Range(rngCurrentFound, rngNextFound.Offset(-1)).Resize(, iWidth)
Else
'It was the last one
'If there are data in column A below the last BANK: use the next line
'Set rngSource = ws.Range(rngCurrentFound, Cells(ws.Range("A" & ws.Range("A:A").Cells.Count).End(xlUp), iWidth))
'Use this one to select until the last used cell in the worksheet
Set rngSource = ws.Range(rngCurrentFound, ws.UsedRange.Cells(ws.UsedRange.Cells.Count))
End If
'rngSource.Select
Call Bankcopy(rngSource, rngHeader)
Set rngCurrentFound = rngSearchArea.FindNext(rngCurrentFound)
Loop While rngCurrentFound.Address <> strFirstFound
End Sub
Private Sub Bankcopy(rngSource As Range, ByVal rngHeader As Range)
'Create new book and copy headers
Dim wbNewBook As Workbook
Set wbNewBook = Workbooks.Add()
Dim wsNewSheet As Worksheet
Set wsNewSheet = wbNewBook.Worksheets(1)
Dim rngTarget As Range
'Copy header
Set rngTarget = wsNewSheet.Range("A1") 'To header left upper
rngHeader.Copy
rngTarget.PasteSpecial xlPasteValues
rngTarget.PasteSpecial xlPasteFormats
Application.CutCopyMode = False
'Copy data
Set rngTarget = wsNewSheet.Range("A8") 'Data left upper
rngSource.Copy
rngTarget.PasteSpecial xlPasteValues
rngTarget.PasteSpecial xlPasteFormats
Application.CutCopyMode = False
'MsgBox "Test Stop"
'wbNewBook.Close
End Sub