VBA code to find heading and copy data

[Todd_H]

Hello,
I am a VBA noob and I was hoping that someone could assist with a code for what I am trying to do. These threads have helped me a lot since beginning my macro journey.

I have data that provides employee service history, this can vary in length from employee to employee. The data is about half way down the report and has a heading in column A "current service" and below the heading in columns A, B, C, D and E is the data I want to copy to another sheet where a table is. Below the current service data is a new heading, also in column A, so I want the code to stop reading and copying data when the new heading is found.


Any help you would be able to give would be great.

Thanks in advance.

 

[Trebor76]

Hi Todd_H,

Welcome to MrExcel!!

Change any code line in the following that I've commented with "<-" to suit your needs and then see how this goes:

Option Explicit
Sub Macro1()

    Dim wsFrom As Worksheet, wsTo As Worksheet
    Dim rngFrom As Range, rngTo As Range
    Dim lngPasteRow As Long
    
    Application.ScreenUpdating = False
    
    Set wsFrom = ThisWorkbook.Sheets("Sheet1") '<-Sheet name containing data to be copied. Change to suit if necessary.
    Set wsTo = ThisWorkbook.Sheets("Sheet2") '<-Sheet name where the data from 'wsFrom' will be paste to. Change to suit if necessary.
    Set rngFrom = wsFrom.Cells.Find(What:="current service", LookIn:=xlValues, LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False, SearchFormat:=False).Offset(1, 0)
    Set rngTo = wsFrom.Cells.Find(What:="end service", LookIn:=xlValues, LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False, SearchFormat:=False).Offset(-1, 0) '<-'end service' will need to be changed to whatever text you want the code to find as its second heading.
    lngPasteRow = wsTo.Range("A:E").Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row + 1 '<-Paste into the next available row acros columns A to E of 'wsTo'. Change to suit if necessary.
    wsFrom.Range("A" & rngFrom.Row & ":E" & rngTo.Row).Copy Destination:=wsTo.Range("A" & lngPasteRow) '<-Pastes into Col. A of 'wsTo'. Change to suit if necessary.
    
    Application.ScreenUpdating = False

End Sub

Regards,

Robert

 

[Todd_H]

Hi Todd_H,

Welcome to MrExcel!!

Change any code line in the following that I've commented with "<-" to suit your needs and then see how this goes:

Option Explicit
Sub Macro1()

    Dim wsFrom As Worksheet, wsTo As Worksheet
    Dim rngFrom As Range, rngTo As Range
    Dim lngPasteRow As Long
   
    Application.ScreenUpdating = False
   
    Set wsFrom = ThisWorkbook.Sheets("Sheet1") '<-Sheet name containing data to be copied. Change to suit if necessary.
    Set wsTo = ThisWorkbook.Sheets("Sheet2") '<-Sheet name where the data from 'wsFrom' will be paste to. Change to suit if necessary.
    Set rngFrom = wsFrom.Cells.Find(What:="current service", LookIn:=xlValues, LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False, SearchFormat:=False).Offset(1, 0)
    Set rngTo = wsFrom.Cells.Find(What:="end service", LookIn:=xlValues, LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False, SearchFormat:=False).Offset(-1, 0) '<-'end service' will need to be changed to whatever text you want the code to find as its second heading.
    lngPasteRow = wsTo.Range("A:E").Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row + 1 '<-Paste into the next available row acros columns A to E of 'wsTo'. Change to suit if necessary.
    wsFrom.Range("A" & rngFrom.Row & ":E" & rngTo.Row).Copy Destination:=wsTo.Range("A" & lngPasteRow) '<-Pastes into Col. A of 'wsTo'. Change to suit if necessary.
   
    Application.ScreenUpdating = False

End Sub

Regards,

Robert

Thank you Robert,
This works great.
I have across another issue with my data that you may be able to help with.
When capturing the data under the heading in one of the columns there is a blank cell, I need the cell to change those cells from blank cells to show a "Y" but only for blanks cells that are under the heading "current service" but before the next heading.
This can be a seperate macro to covert the cells before running your above macro to copy the data.
Thanks again.

 

[Trebor76]

When capturing the data under the heading in one of the columns there is a blank cell, I need the cell to change those cells from blank cells to show a "Y" but only for blanks cells that are under the heading "current service" but before the next heading.

Try this:

Option Explicit
Sub Macro1()

    Dim wsFrom As Worksheet, wsTo As Worksheet
    Dim rngFrom As Range, rngTo As Range
    Dim lngPasteRow As Long
    Dim strMyCol As String
    
    Application.ScreenUpdating = False
    
    Set wsFrom = ThisWorkbook.Sheets("Sheet1") '<-Sheet name containing data to be copied. Change to suit if necessary.
    Set wsTo = ThisWorkbook.Sheets("Sheet2") '<-Sheet name where the data from 'wsFrom' will be paste to. Change to suit if necessary.
    Set rngFrom = wsFrom.Cells.Find(What:="current service", LookIn:=xlValues, LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False, SearchFormat:=False).Offset(1, 0)
    Set rngTo = wsFrom.Cells.Find(What:="end service", LookIn:=xlValues, LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False, SearchFormat:=False).Offset(-1, 0) '<-'end service' will need to be changed to whatever text you want the code to find as its second heading.
    strMyCol = Split(rngFrom.Address, "$")(1)
    wsFrom.Range(strMyCol & rngFrom.Row & ":" & strMyCol & rngTo.Row).SpecialCells(xlCellTypeBlanks).Value = "Y"
    lngPasteRow = wsTo.Range("A:E").Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row + 1 '<-Paste into the next available row acros columns A to E of 'wsTo'. Change to suit if necessary.
    wsFrom.Range("A" & rngFrom.Row & ":E" & rngTo.Row).Copy Destination:=wsTo.Range("A" & lngPasteRow) '<-Pastes into Col. A of 'wsTo'. Change to suit if necessary.
    
    Application.ScreenUpdating = False

End Sub

Regards,

Robert