macro to find text heading then select underlying data?

**excelRookie06** · 08-06-2011, 01:07 AM

Hi, I don't expect a solution for this, but it would be great to know if it might be possible. Looking at the attached worksheet, would it be possible to search for a text heading (i.e. Group A) and then select all rows and columns underneath that heading until there is an empty cell?

The format of my actual data extract is just like this, where the text heading is listed, then dashes below, then data. The amount of rows will vary, that's why I hope to select all for each keyword until an empty row appears.

If it is possible to find and select that data, I then want to cut and past in a new worksheet tab.

thanks for any input!

**JBeaucaire** · 08-06-2011, 01:34 AM

Searching for "Group A" is simple and selecting all the data in the range of cells attached to that cell is also pretty simple. What you left out was what to DO with that once it is found.

This little macro will find your search string, and copy the data set to sheet2.

Option Explicit

Sub FindSpecial()
Dim sFIND As Range

MySearch = Application.InputBox("What string to search for?", "Search", "cat", Type:=2)
If MySearch = "False" Then Exit Sub

On Error Resume Next
Set sFIND = RNG.Find(MySearch, LookIn:=xlValues, LookAt:=xlPart)

If Not sFIND Is Nothing Then
    sFIND.CurrentRegion.Copy Sheets("Sheet2").Range("A1")
Else
    MsgBox "Search string '" & MySearch & "' was not found."
End If

End Sub

**JohnM3** · 08-06-2011, 03:37 AM

Hi
.
You will have to save your file as an Excel Macro file.
.
Then you will have to add a module for putting code in.
.
Note: There are general modules and Class modules.
You want to add a General module in that the code below
is for a general module.
.
Based on your original Excel file I have made the assumption that all data
blocks begin with the word GROUP e.g. Group A , Group B etc.
.
If that assumption is NOT true then the code below will fail.
.
Please note the following about the code below:

* Alot of it will seem like gibberish. Just ignore most of it and look for a
subroutine called PUBLIC SUB MAIN. Once you have found it - put your
cursor in it and run it using the F8 key or the Shift F8 to by pass going into
lower sub routines.

* It is "more correct" to use local variables in a sub-routine but I not done this
and created properties for various counts and other thingies. They are being
used in place of local variables.

* I tested the code by (1) using what you had and (2) adding additional GROUPS
with various # of blank lines between them and the code seems to work,
.
BUT - the code assumes that the KEY WORD GROUP is **always** there
and **always** in the 1st column.

* This code is NOT elegant or the fastest way to do it - but its the way
I think. -g-
.
Just copy and paste the code below into the module I described above.
.
As in your example - I ASSUME data is in SHEET1 and you want to
write to SHEET2. (You can change this in the code if required)
.
HTH
regards
John


Option Explicit

Const START_COLUMN As String = "A"
Const KEY_WORD_GROUP As String = "GROUP"
Const WILD_CARD As String = "*"
Const FIRST_COLUMN As Integer = 1

Private mo_WSData As Excel.Worksheet ' Your Original WS with data
Private mo_WS_WriteTo As Excel.Worksheet ' The WS that the data blocks w/be written to

Private mo_RngAllData As Excel.Range
Private mo_RngFirstColumn As Excel.Range
Private mo_RngDataBlock As Excel.Range

Private ms_WSName As String
Private mlng_LastRow As Long
Private mlng_CurrentRow As Long
Private mlng_NextRow As Long
Private mlng_LastColumn As Long
Private mlng_CNTBlanks As Long
Private mlng_CNTGroupWord As Long
Public Property Get CNTBlanks() As Long
    CNTBlanks = mlng_CNTBlanks
    Exit Property
End Property
Public Property Let CNTBlanks(lng As Long)
    mlng_CNTBlanks = lng
    Exit Property
End Property
Public Property Get CNTGroupWord() As Long
    CNTGroupWord = mlng_CNTGroupWord
    Exit Property
End Property
Public Property Let CNTGroupWord(lng As Long)
    mlng_CNTGroupWord = lng
    Exit Property
End Property
Public Property Get CurrentRow() As Long
    CurrentRow = mlng_CurrentRow
    Exit Property
End Property
Public Property Let CurrentRow(lng As Long)
    mlng_CurrentRow = lng
    Exit Property
End Property
Public Property Get NextRow() As Long
    NextRow = mlng_NextRow
    Exit Property
End Property
Public Property Let NextRow(lng As Long)
    mlng_NextRow = lng
    Exit Property
End Property
Public Property Get LastColumn() As Long
    LastColumn = mlng_LastColumn
    Exit Property
End Property
Public Property Let LastColumn(lng As Long)
    mlng_LastColumn = lng
    Exit Property
End Property
Public Property Get LastRow() As Long
    LastRow = mlng_LastRow
    Exit Property
End Property
Public Property Let LastRow(lng As Long)
    mlng_LastRow = lng
    Exit Property
End Property
Public Sub Main()
    
    On Error GoTo EH_Main
    
    Dim lng As Long
    
    '-----------------
    '   WS Data Blocks will be Written to
    '-----------------
    WS_Name = "Sheet2"
    Set WS_WriteTo = Sheets(WS_Name)
    
    '-----------------
    '   Clear out old data - if any
    '-----------------
    WS_WriteTo.Cells.Delete
    
    '-----------------
    '   WS Containing Data
    '-----------------
    WS_Name = "Sheet1"
    Set WS_Data = Sheets(WS_Name)
    
    '-----------------
    '   Make WS_Data (Sheet1) the Active Worksheet
    '-----------------
    WS_Data.Select
    
    '-----------------
    '   Last Row/Last Column containing data
    '-----------------
    LastRow = Cells(Rows.Count, START_COLUMN).End(xlUp).Row
    LastColumn = Cells(1, 1).End(xlToRight).Column
    
    '-----------------
    '   Range of All Data including BLANK rows
    '-----------------
    With WS_Data
        Set Rng_AllData = .Range(Cells(1, 1), Cells(LastRow, LastColumn))
        '-----------------
        '   Range which consists of ONLY column 1 in Range Rng_AllData
        '-----------------
        Set Rng_FirstColumn = Rng_AllData.Columns(FIRST_COLUMN)
    End With
    
    '-----------------
    '   Information Counts - based on Range Rng_FirstColumn
    '   CNTGroupWord is used in a FOR LOOP
    '-----------------
    With WorksheetFunction
        '-----------------
        '   Total # of Blank Cells in Range First Column
        '-----------------
        CNTBlanks = .CountBlank(Rng_FirstColumn)
        '-----------------
        '   Total # of Cells containing the word GROUP
        '-----------------
        CNTGroupWord = .CountIf(Rng_FirstColumn, KEY_WORD_GROUP & WILD_CARD)
    End With
    
    '-----------------
    '   Using a For Loop based on CNTGroupWord
    '-----------------
    For lng = 1 To CNTGroupWord
    
        '-----------------
        '-----------------
        Select Case lng
            Case 1
            
                '--------------------
                '   Find First NON-BLANK after Row 1 (in the 1st column)
                '--------------------
                CurrentRow = Rng_FirstColumn.Cells(1, 1).End(xlDown).Row
                
                '--------------------
                '   The 1st Block of Data
                '--------------------
                With WS_Data
                    Set Rng_DataBlock = .Range("A" & CurrentRow).CurrentRegion
                    Rng_DataBlock.Copy WS_WriteTo.Range(Rng_DataBlock.Address)
                End With
            
                '--------------------
                '   Start Row for next .End(xlDown) operation
                '--------------------
                NextRow = Rng_DataBlock.Rows(Rng_DataBlock.Rows.Count).Row
                
                '--------------------
                '   Find First NON-BLANK after Row NextRow (in the 1st column)
                '--------------------
                CurrentRow = Rng_FirstColumn.Cells(NextRow, 1).End(xlDown).Row
        
        Case Else
            
                '--------------------
                '   Subsequent Blocks of Data
                '--------------------
                With WS_Data
                    Set Rng_DataBlock = .Range("A" & CurrentRow).CurrentRegion
                    Rng_DataBlock.Copy WS_WriteTo.Range(Rng_DataBlock.Address)
                End With
                
                '--------------------
                '   Start Row for next .End(xlDown) operation
                '--------------------
                NextRow = Rng_DataBlock.Rows(Rng_DataBlock.Rows.Count).Row
                CurrentRow = Rng_FirstColumn.Cells(NextRow, 1).End(xlDown).Row
        
        End Select
    
    Next
    
    '--------------------
    '   Exit this routine
    '--------------------
    Exit Sub

EH_Main:
    MsgBox Err.Number & " " & Err.Description, vbCritical, "Public Sub Main()"
    Exit Sub
End Sub
Public Property Get Rng_AllData() As Excel.Range
    Set Rng_AllData = mo_RngAllData
    Exit Property
End Property
Public Property Set Rng_AllData(o As Excel.Range)
    Set mo_RngAllData = o
    Exit Property
End Property
Public Property Get Rng_DataBlock() As Excel.Range
    Set Rng_DataBlock = mo_RngDataBlock
    Exit Property
End Property
Public Property Set Rng_DataBlock(o As Excel.Range)
    Set mo_RngDataBlock = o
    Exit Property
End Property
Public Property Get Rng_FirstColumn() As Excel.Range
    Set Rng_FirstColumn = mo_RngFirstColumn
    Exit Property
End Property
Public Property Set Rng_FirstColumn(o As Excel.Range)
    Set mo_RngFirstColumn = o
    Exit Property
End Property
Public Property Get WS_Data() As Excel.Worksheet
    Set WS_Data = mo_WSData
    Exit Property
End Property
Public Property Set WS_Data(o As Excel.Worksheet)
    Set mo_WSData = o
    Exit Property
End Property
Public Property Get WS_Name() As String
    WS_Name = ms_WSName
    Exit Property
End Property
Public Property Let WS_Name(s As String)
    ms_WSName = s
    Exit Property
End Property
Public Property Get WS_WriteTo() As Excel.Worksheet
    Set WS_WriteTo = mo_WS_WriteTo
    Exit Property
End Property
Public Property Set WS_WriteTo(o As Excel.Worksheet)
    Set mo_WS_WriteTo = o
    Exit Property
End Property

**gjlindn** · 08-06-2011, 04:10 AM

I'm betting you're looking for something like this.

Sub TxfrSections()
    Dim wsData      As Worksheet
    Dim wsNew       As Worksheet
    Dim rHeader     As Range
    Dim rCopy       As Range
    Dim rBottom     As Range
    Dim lCalc       As Long
    Dim bScrUpdt    As Boolean
    Dim bEvents     As Boolean
    
    'Speed things up
    lCalc = Application.Calculation
    bScrUpdt = Application.ScreenUpdating
    bEvents = Application.EnableEvents
    Application.Calculation = xlCalculationManual
    Application.ScreenUpdating = False
    Application.EnableEvents = False
    
    'Set variables
    Set wsData = Sheets("Sheet1")   'sheet with your data on it
    Set rHeader = Range("A1:I1")    'range where your headers reside
    Set rBottom = wsData.Cells(Rows.Count, rHeader.Column).End(xlUp)
    Set rCopy = rHeader
    
    'CopyData
    Do
        Set rCopy = rCopy.Cells(rCopy.Rows.Count, rHeader.Column).Offset(0, 1).End(xlDown).Offset(0, -1)
        Set rCopy = wsData.Range(rCopy, rCopy.End(xlDown).Offset(0, rHeader.Columns.Count - 1))
        Set wsNew = Sheets.Add
        wsNew.Name = rCopy.Offset(-2).Resize(1, 1).Text
        wsNew.Range("A1").Resize(1, rHeader.Columns.Count).Value = rHeader.Value
        wsNew.Range("A2").Resize(rCopy.Rows.Count, rCopy.Columns.Count).Formula = rCopy.Formula
        wsNew.Move After:=Sheets(Sheets.Count)
    Loop Until rCopy.Cells(rCopy.Rows.Count, rHeader.Column).Row = rBottom.Row
    
    'Cleanup
    Set wsData = Nothing
    Set rHeader = Nothing
    Set rBottom = Nothing
    Set rCopy = Nothing
    Set wsNew = Nothing
    
    'Restore settings
    Application.Calculation = lCalc
    Application.ScreenUpdating = bScrUpdt
    Application.EnableEvents = bEvents
End Sub

**JohnM3** · 08-06-2011, 10:41 AM

Hi
I woke up this morning and realized that what I posted is NOT what you wanted.
Very simply (if I am correct) you are simply trying to write the FINANCIAL DATA ONLY
to another worksheet.
Additionally, I am assuming that you WANT the column headings.
If these assumptions are correct - then here is the revised code.
HTH
regards
John

Option Explicit
Const START_COLUMN As String = "A"
Const FIRST_COLUMN As Integer = 1
Const FIRST_ROW As Integer = 1
Const KEY_WORD_GROUP As String = "GROUP"
Const WILD_CARD As String = "*"
Const CELL_A1 As String = "A1"
Private mo_WSData As Excel.Worksheet
Private mo_WS_WriteTo As Excel.Worksheet
Private mo_RngAllData As Excel.Range
Private mo_RngFirstColumn As Excel.Range
Private mo_RngDataBlock As Excel.Range
Private mo_RngColumnHeadings As Excel.Range
Private mo_RngExistingDataOnWSWriteTo As Excel.Range
Private ms_WSName As String
Private mlng_LastRow As Long
Private mlng_CurrentRow As Long
Private mlng_NextRow As Long
Private mlng_TargetRow As Long
Private mlng_LastColumn As Long
Private mlng_CNTBlanks As Long
Private mlng_CNTGroupWord As Long
Public Property Get CNTBlanks() As Long
    CNTBlanks = mlng_CNTBlanks
    Exit Property
End Property
Public Property Let CNTBlanks(lng As Long)
    mlng_CNTBlanks = lng
    Exit Property
End Property
Public Property Get CNTGroupWord() As Long
    CNTGroupWord = mlng_CNTGroupWord
    Exit Property
End Property
Public Property Let CNTGroupWord(lng As Long)
    mlng_CNTGroupWord = lng
    Exit Property
End Property
Public Property Get CurrentRow() As Long
    CurrentRow = mlng_CurrentRow
    Exit Property
End Property
Public Property Let CurrentRow(lng As Long)
    mlng_CurrentRow = lng
    Exit Property
End Property
Public Property Get NextRow() As Long
    NextRow = mlng_NextRow
    Exit Property
End Property
Public Property Let NextRow(lng As Long)
    mlng_NextRow = lng
    Exit Property
End Property
Public Property Get TargetRow() As Long
    TargetRow = mlng_TargetRow
    Exit Property
End Property
Public Property Let TargetRow(lng As Long)
    mlng_TargetRow = lng
    Exit Property
End Property
Public Property Get LastColumn() As Long
    LastColumn = mlng_LastColumn
    Exit Property
End Property
Public Property Let LastColumn(lng As Long)
    mlng_LastColumn = lng
    Exit Property
End Property
Public Property Get LastRow() As Long
    LastRow = mlng_LastRow
    Exit Property
End Property
Public Property Let LastRow(lng As Long)
    mlng_LastRow = lng
    Exit Property
End Property
Public Sub Main()
    
    On Error GoTo EH_Main
    
    Dim lng As Long
    
    '   WS Data Blocks will be Written to
    WS_Name = "Sheet2"
    Set WS_WriteTo = Sheets(WS_Name)
    
    '   Clear out old data - if any
    WS_WriteTo.Cells.Delete
    
    '   WS Containing Data
    WS_Name = "Sheet1"
    Set WS_Data = Sheets(WS_Name)
    
    '   Make WS_Data (Sheet1) the Active Worksheet
    WS_Data.Select
    
    '   Last Row/Last Column containing data
    LastRow = Cells(Rows.Count, START_COLUMN).End(xlUp).Row
    LastColumn = Cells(1, 1).End(xlToRight).Column
    
    '   Create Needed Ranges
    With WS_Data
        
        '   Range of All Data including BLANK rows
        Set Rng_AllData = .Range(Cells(1, 1), Cells(LastRow, LastColumn))
        
        '   Range - First Column of Rng_AllData
        Set Rng_FirstColumn = Rng_AllData.Columns(FIRST_COLUMN)
        
        '   Range - First Row of Rng_AllData
        Set Rng_ColumnHeadings = Rng_AllData.Rows(FIRST_ROW)
    
    End With
    
    '   Information Counts - based on Range Rng_FirstColumn
    '   CNTGroupWord is used in a FOR LOOP
    With WorksheetFunction
        '   Total # of Blank Cells in Range First Column
        CNTBlanks = .CountBlank(Rng_FirstColumn)
        '   Total # of Cells containing the word GROUP
        CNTGroupWord = .CountIf(Rng_FirstColumn, KEY_WORD_GROUP & WILD_CARD)
    End With
    
    '   Using a For Loop based on CNTGroupWord
    For lng = 0 To CNTGroupWord
    
        Select Case lng
            
            Case 0
                '   Copy Headings to WS_WriteTo (Sheets2)
                Rng_ColumnHeadings.Copy WS_WriteTo.Cells(1, 1)
            
            Case 1
                '   Find First NON-BLANK after Row 1 (in 1st column)
                CurrentRow = Rng_FirstColumn.Cells(1, 1).End(xlDown).Row
                
                '   Get 1st Block of Data
                With WS_Data
                    'Includes Group Word and Underline
                    Set Rng_DataBlock = .Range("A" & CurrentRow).CurrentRegion
                    'Excludes Group Word and Underline BUT adds 2 unwanted rows
                    Set Rng_DataBlock = Rng_DataBlock.Offset(2, 0)
                    'Resets Range to correct size
                    Set Rng_DataBlock = Rng_DataBlock.Resize(Rng_DataBlock.Rows.Count - 2, Rng_DataBlock.Columns.Count)
                End With
            
                '   Determine Next Row on WS_WriteTo
                With WS_WriteTo
                    Set Rng_ExistingDataOnWSWriteTo = .Range(CELL_A1).CurrentRegion
                    TargetRow = Rng_ExistingDataOnWSWriteTo.Rows.Count + 1
                End With
                
                '   Copy data to WS_WriteTo (Sheets2)
                Rng_DataBlock.Copy WS_WriteTo.Cells(TargetRow, 1)
            
                '   Start Row for next .End(xlDown) operation
                NextRow = Rng_DataBlock.Rows(Rng_DataBlock.Rows.Count).Row
                
                '   Find First NON-BLANK after Row NextRow (in the 1st column)
                CurrentRow = Rng_FirstColumn.Cells(NextRow, 1).End(xlDown).Row
        
        Case Else
                '   Subsequent Blocks of Data
                With WS_Data
                    'Includes Group Word and Underline
                    Set Rng_DataBlock = .Range("A" & CurrentRow).CurrentRegion
                    'Excludes Group Word and Underline BUT adds 2 unwanted rows
                    Set Rng_DataBlock = Rng_DataBlock.Offset(2, 0)
                    'Resets Range to correct size
                    Set Rng_DataBlock = Rng_DataBlock.Resize(Rng_DataBlock.Rows.Count - 2, Rng_DataBlock.Columns.Count)
                End With
                
                '   Determine Next Row on WS_WriteTo
                With WS_WriteTo
                    Set Rng_ExistingDataOnWSWriteTo = .Range(CELL_A1).CurrentRegion
                    TargetRow = Rng_ExistingDataOnWSWriteTo.Rows.Count + 1
                End With
                
                '   Copy data to WS_WriteTo (Sheets2)
                Rng_DataBlock.Copy WS_WriteTo.Cells(TargetRow, 1)
                
                '   Start Row for next .End(xlDown) operation
                NextRow = Rng_DataBlock.Rows(Rng_DataBlock.Rows.Count).Row
                CurrentRow = Rng_FirstColumn.Cells(NextRow, 1).End(xlDown).Row
        
        End Select
    Next
    Exit Sub

EH_Main:
    MsgBox Err.Number & " " & Err.Description, vbCritical, "Public Sub Main()"
    Exit Sub
End Sub
Public Property Get Rng_AllData() As Excel.Range
    Set Rng_AllData = mo_RngAllData
    Exit Property
End Property
Public Property Set Rng_AllData(o As Excel.Range)
    Set mo_RngAllData = o
    Exit Property
End Property
Public Property Get Rng_ColumnHeadings() As Excel.Range
    Set Rng_ColumnHeadings = mo_RngColumnHeadings
    Exit Property
End Property
Public Property Set Rng_ColumnHeadings(o As Excel.Range)
    Set mo_RngColumnHeadings = o
    Exit Property
End Property
Public Property Get Rng_DataBlock() As Excel.Range
    Set Rng_DataBlock = mo_RngDataBlock
    Exit Property
End Property
Public Property Set Rng_DataBlock(o As Excel.Range)
    Set mo_RngDataBlock = o
    Exit Property
End Property
Public Property Get Rng_ExistingDataOnWSWriteTo() As Excel.Range
    Set Rng_ExistingDataOnWSWriteTo = mo_RngExistingDataOnWSWriteTo
    Exit Property
End Property
Public Property Set Rng_ExistingDataOnWSWriteTo(o As Excel.Range)
    Set mo_RngExistingDataOnWSWriteTo = o
    Exit Property
End Property
Public Property Get Rng_FirstColumn() As Excel.Range
    Set Rng_FirstColumn = mo_RngFirstColumn
    Exit Property
End Property
Public Property Set Rng_FirstColumn(o As Excel.Range)
    Set mo_RngFirstColumn = o
    Exit Property
End Property
Public Property Get WS_Data() As Excel.Worksheet
    Set WS_Data = mo_WSData
    Exit Property
End Property
Public Property Set WS_Data(o As Excel.Worksheet)
    Set mo_WSData = o
    Exit Property
End Property
Public Property Get WS_Name() As String
    WS_Name = ms_WSName
    Exit Property
End Property
Public Property Let WS_Name(s As String)
    ms_WSName = s
    Exit Property
End Property
Public Property Get WS_WriteTo() As Excel.Worksheet
    Set WS_WriteTo = mo_WS_WriteTo
    Exit Property
End Property
Public Property Set WS_WriteTo(o As Excel.Worksheet)
    Set mo_WS_WriteTo = o
    Exit Property
End Property