VBA Paste Cells With Specific Text String to Specific Sheet

[hobbiton73]

Hi, I wonder whether someone may be able to help me please.

I'm using the code below to search a dataset for two text strings "Enhancements" and "OVH". When these are found a range of cells on the same row are copied and paste to the "Enhancements" page.

Sub Extract()
    Dim i As Long, j As Long, m As Long
    Dim strProject As String
    Dim RDate As Date
    Dim RVal As Single
    Dim BlnProjExists As Boolean
    With Sheets("Enhancements").Range("B3")
        For i = 1 To .CurrentRegion.Rows.Count - 1
            For j = 0 To 13
                .Offset(i, j) = ""
                Next j
                Next i
            End With
            With Sheets("AllData").Range("E3")
                For i = 1 To .CurrentRegion.Rows.Count - 1
                    strProject = .Offset(i, 0)
                    RDate = .Offset(i, 3)
                    RVal = .Offset(i, 4)
                    If InStr(.Offset(i, 0), "Enhancements") > 0 Then
                        strProject = .Offset(i, 0)
                    ElseIf InStr(.Offset(i, 0), "OVH") > 0 And RVal > 0 Then
                        strProject = .Offset(i, -1)
                    Else
                        GoTo NextLoop
                    End If
                    
                    With Sheets("Enhancements").Range("B3")
                        If .CurrentRegion.Rows.Count = 1 Then
                            .Offset(1, 0) = strProject
                            j = 1
                        Else
                            BlnProjExists = False
                            For j = 1 To .CurrentRegion.Rows.Count - 1
                                If .Offset(j, 0) = strProject Then
                                    BlnProjExists = True
                                    Exit For
                                End If
                                Next j
                                If BlnProjExists = False Then
                                    .Offset(j, 0) = strProject
                                End If
                            End If
                            Select Case Format(RDate, "mmm yy")
                            Case "Apr 13"
                                m = 1
                            Case "May 13"
                                m = 2
                            Case "Jun 13"
                                m = 3
                            Case "Jul 13"
                                m = 4
                            Case "Aug 13"
                                m = 5
                            Case "Sep 13"
                                m = 6
                            Case "Oct 13"
                                m = 7
                            Case "Nov 13"
                                m = 8
                            Case "Dec 13"
                                m = 9
                            Case "Jan 14"
                                m = 10
                            Case "Feb 14"
                                m = 11
                            Case "Mar 14"
                                m = 12
                            End Select
                            .Offset(j, m) = .Offset(j, m) + RVal
                        End With
                        NextLoop:
                        Next i
                    End With
                End Sub

However I kneed to make a change to this which affects this part of the script:

With Sheets("AllData").Range("E3")
    For i = 1 To .CurrentRegion.Rows.Count - 1
    strProject = .Offset(i, 0)
    RDate = .Offset(i, 3)
    RVal = .Offset(i, 4)
     If InStr(.Offset(i, 0), "Enhancements") > 0 Then
            strProject = .Offset(i, 0)
        ElseIf InStr(.Offset(i, 0), "OVH") > 0 And RVal > 0 Then
            strProject = .Offset(i, -1)
        Else
            GoTo NextLoop
        End If


        With Sheets("Enhancements").Range("B3")
            If .CurrentRegion.Rows.Count = 1 Then
                .Offset(1, 0) = strProject
                j = 1
            Else
                BlnProjExists = False
                For j = 1 To .CurrentRegion.Rows.Count - 1
                    If .Offset(j, 0) = strProject Then
                        BlnProjExists = True
                        Exit For
                    End If

What I'd like to do is keep the functionality whereby if the text value of "Enhancements" is found the relevant data is copied and paste to the "Enhancements" sheet, but if "OVH" is found I would like to change this so that the the information is paste to the "Overheads" sheet.

I thought this may be simple, but after working on this all week I still can't find the solution.

I just wondered whether someone could possibly look at this please and offer some guidance on how I may go about achieving this. Because I'm relatively new to VBA, it would be helpful if the solution was as simple as possible, so that I can learn from this.

Many thanks and kind regards

[SamT]

Do me a favor: Format the Sub Extract with indentations and report it in Code tags like you did the "With Sheets("AllData")" code. Thanks.

[Zack Barresse]

Hello there,

I added CODE tags to your first piece of code in your post.

Can you be more specific about your requirements? You said but if "OVH" is found which is not exactly helpful. Do you mean to say...

• Look for "OVH" first, if found use "Overheads" sheet
• Look for "Enhancements" next, if found use "Enhancements" sheet

Or do you mean to say...

• Look for "Enhancements" first, if found use "Enhancements" sheet
• Look for "OVH" next, if found use "Overheads" sheet

[hobbiton73]

Hi @SamT, thank you very much for taking the time to reply to my post.

My apologies for the code format. I've now changed this, so hopefully it will be a little easier to read.

Many thanks and kind regards

[hobbiton73]

Hi @Zack Barresse, thank you for taking the time to reply to my post, and my sincere apologies for not making this clear.

I've attached a file which may help. To use this, please select the 'Macros' sheet and

but in answer to your question, I have no preference to which value the script looks for first. The main aim is to keep the current functionality, but to tweak this, so if the value "OVH" is found it copies and pastes the relevant data to the "Overheads" sheet rather than the "Enhancements".

I hope this helps.

Many thanks and kind regards

[Zack Barresse]

The file has no macros in it. You have your button linked to a macro in...

'D:\Work Files\Test.xls'!Extract

We don't have that file, so not sure what you expect us to be able to look at. ??

If you're using the new file formats, why aren't you using tables?

This code assumes you have no data in either the Enhancements or Overheads worksheets below the headers on row 3. It will not clear past data if already entered. It assumes your header row will not move (if you were using tables we could do this easily).

Sub Extract_v2()

    Dim DataSheet As Worksheet
    Dim VarSheet As Worksheet
    Dim DateCell As Range
    Dim iLastRow As Long
    Dim iStep As Long
    Dim iRow As Long
    Dim iCol As Long
    Dim DestSheetName As String
    
    Set DataSheet = ThisWorkbook.Worksheets("AllData")
    
    iLastRow = DataSheet.Cells(DataSheet.Rows.Count, "E").End(xlUp).Row
    For iStep = 4 To iLastRow
        
        If InStr(1, DataSheet.Cells(iStep, "E").Value, "OVH", vbTextCompare) > 0 Then
            DestSheetName = "Overheads"
        ElseIf InStr(1, DataSheet.Cells(iStep, "E").Value, "Enhancements", vbTextCompare) > 0 Then
            DestSheetName = "Enhancements"
        Else
            DestSheetName = vbNullString
        End If
        
        If DestSheetName <> vbNullString Then
            Set VarSheet = ThisWorkbook.Worksheets(DestSheetName)
            iRow = VarSheet.Cells(VarSheet.Rows.Count, "B").End(xlUp).Row + 1
            Set DateCell = VarSheet.Range("C3:N3").Find(What:=Format(DataSheet.Cells(iStep, "H").Value, "mmm-yy"), LookIn:=xlValues)
            If Not DateCell Is Nothing Then
                VarSheet.Cells(iRow, DateCell.Column).Value = DataSheet.Cells(iStep, "I").Value
                VarSheet.Cells(iRow, DateCell.Column).NumberFormat = DataSheet.Cells(iStep, "I").NumberFormat
            End If
        End If
        
    Next iStep
    
End Sub

[hobbiton73]

Hi @Zack Barresse, thank you very much for your continued help with this, and once again my apologies for not making things easy for you.

I'm at work now, so I'm unbale to re-attach the file, but the code which needs to be attached to the button, is as per my original post, so I'm not sure how easy it would be for you to add a button and assign the macro to it.

In respect of your queries around the use of tables. I would have liked to use these, but although I'm using Office 2013 at home, I'm using Office 2003 at work.

Thank you also for the code you kindly provided. I've tried this, but unfortunately, this doesn't provide the deasired effect because he descriptions are not paste from the Source to the Destination sheet, and the code seems to stop once the first value has been paste to the Destination sheet.

Because I know my exisiting code is 90% of the way there, could you tell me please, is there anyway to you use this with the tweak for when the string value is "OVH"?

Many thanks and kind regards

[Zack Barresse]

Hi,

I understand work.

Because I know my exisiting code is 90% of the way there, could you tell me please, is there anyway to you use this with the tweak for when the string value is "OVH"?

It seems to work for me just fine. I'm assuming you want the values from column E to go into the destination sheets column B then? Please explain your exact requirements in your posts. It helps get the solution exactly as you need in the least amount of attempts.

You would only need to add a single line to bring in the descriptions into column B of the destination sheets...

Sub Extract_v2()

    Dim DataSheet As Worksheet
    Dim VarSheet As Worksheet
    Dim DateCell As Range
    Dim iLastRow As Long
    Dim iStep As Long
    Dim iRow As Long
    Dim iCol As Long
    Dim DestSheetName As String
    
    Set DataSheet = ThisWorkbook.Worksheets("AllData")
    
    iLastRow = DataSheet.Cells(DataSheet.Rows.Count, "E").End(xlUp).Row
    For iStep = 4 To iLastRow
        
        If InStr(1, DataSheet.Cells(iStep, "E").Value, "OVH", vbTextCompare) > 0 Then
            DestSheetName = "Overheads"
        ElseIf InStr(1, DataSheet.Cells(iStep, "E").Value, "Enhancements", vbTextCompare) > 0 Then
            DestSheetName = "Enhancements"
        Else
            DestSheetName = vbNullString
        End If
        
        If DestSheetName <> vbNullString Then
            Set VarSheet = ThisWorkbook.Worksheets(DestSheetName)
            iRow = VarSheet.Cells(VarSheet.Rows.Count, "B").End(xlUp).Row + 1
            VarSheet.Cells.EntireColumn.AutoFit
            Set DateCell = VarSheet.Range("C3:N3").Find(What:=Format(DataSheet.Cells(iStep, "H").Value, "mmm-yy"), LookIn:=xlValues)
            If Not DateCell Is Nothing Then
                VarSheet.Cells(iRow, DateCell.Column).Value = DataSheet.Cells(iStep, "I").Value
                VarSheet.Cells(iRow, DateCell.Column).NumberFormat = DataSheet.Cells(iStep, "I").NumberFormat
                VarSheet.Cells(iRow, "B").Value = DataSheet.Cells(iStep, "E").Value
            End If
        End If
        
    Next iStep
    
End Sub

Edit: I was having a problem with dates not being found with the date cell columns being too small for some reason. Code line added to account for this.

HTH

[hobbiton73]

Hi @Zack Barresse, thank you very much for coming back to me with this and for being so understanding. I admit I've found it a difficult one to explain.

I've tried your code, and certainly with a very unhelpful explanation from me, you've pretty much got it.

If I may, could I just ask a couple of things:

• In the code I originally posted, when the value from column E of the 'Source' file is copied, it is paste into the 'Destination' sheet creating a unique distinct list, i.e. the same "Description" value will not be found more than once in column B of the 'Destination' sheet. In addition, the 'Actuals' figure from column I are totalled under the relevant monthly column. This applies to both the the "Enhancements" and "Overheads" sheets. so for example:

Source sheet

Column E	Column H	Column I
B&C General Enhancements C&R FY13	01/04/13	5
B&C General Enhancements C&R FY13	01/07/13	2
B&C General Enhancements C&R FY13	01/04/13	15

will become

Destination sheet

Column B

Column C

Column D

Column E

Column F

Column G

Column H

Column I

Column J

Column K

Column L

Column M

Column N

April

May

June

July

August

September

October

November

December

January

February

March

B&C General Enhancements C&R FY13

20

2

• The second item relates to the "OVH" entries. Would it be possible please to copy the value from column D rather than column E on the 'Source' sheet, to paste into column B of the 'Destination' sheet.

I am sorry for the headache I've given you, but I hope this helps, and I've certainly learnt a valuable lesson.

Once again, many thanks for all your time, trouble and patience.

Kind Regards

[Zack Barresse]

No worries at all. No headache. That is a much clearer explanation of your needs. Let me address the two issues.

Getting the values from column D instead of E is a very simple change, and is with this line...

 VarSheet.Cells(iRow, "B").Value = DataSheet.Cells(iStep, "E").Value

You would only need to change the "E" to "D" and voila.

The other item you talked about was if the description was the same to keep the values in the same row. This isn't a problem but will take more than just one line of code. What if there is already a value for that description/month? Should it just overwrite it? Leave it alone?

Also, what about previously existing data? Should the destination sheets (data range) be cleared when this runs to only get the current data? Should it be appended to the list of data already in the destination sheets?

[hobbiton73]

Hi, thank you very much for coming back to me with this.

I've amended the line of code as you suggested, I think in the correct place, so this section of code:

If Not DateCell Is Nothing Then
                VarSheet.Cells(iRow, DateCell.Column).Value = DataSheet.Cells(iStep, "I").Value
                VarSheet.Cells(iRow, DateCell.Column).NumberFormat = DataSheet.Cells(iStep, "I").NumberFormat
                VarSheet.Cells(iRow, "B").Value = DataSheet.Cells(iStep, "E").Value
            End If

becomes

If Not DateCell Is Nothing Then
                VarSheet.Cells(iRow, DateCell.Column).Value = DataSheet.Cells(iStep, "I").Value
                VarSheet.Cells(iRow, DateCell.Column).NumberFormat = DataSheet.Cells(iStep, "I").NumberFormat
                VarSheet.Cells(iRow, "B").Value = DataSheet.Cells(iStep, "D").Value
            End If

and although the "Overheads" sheet is correctly populated with the correct description and associated 'Actuals' data, the descriptions and the associated 'Actuals' figures no longer appear on the "Enhancements" page, so I'm not too sure what I've done wrong?

In answer to your query, when I run this I'll be starting with blank "Enhancements" and "Overheads" sheets, so there is no need to have the functionality which overwrites or clears cell contents.

I hope this helps.

Once again sincere thanks for all your help, it is truely appreciated.

Kind Regards

[hobbiton73]

Unfortunately I was unable to get a working solution to this problem here at this forum.

However after visiting 'Excel Help' forum, I received the following working solution from @AB33.

Sub Extract1()
    Dim i As Long, j As Long, m As Long, strProject As String, RDate As Date, RVal As Single
    Dim BlnProjExists As Boolean, OH As Worksheet, EH As Worksheet
    Application.ScreenUpdating = 0
Set EH = Sheets("Enhancements")
Set OH = Sheets("Overheads")
EH.Rows("4:" & Rows.Count).Clear
OH.Rows("4:" & Rows.Count).Clear
 With Sheets("AllData").Range("E3")
    For i = 1 To .CurrentRegion.Rows.Count - 1
        strProject = .Offset(i, 0)
        RDate = .Offset(i, 3)
        RVal = .Offset(i, 4)
     If InStr(.Offset(i, 0), "Enhancements") > 0 Then
            strProject = .Offset(i, 0)
          
        With EH.Range("B3")
            If .CurrentRegion.Rows.Count = 1 Then
                .Offset(1, 0) = strProject
                j = 1
            Else
                BlnProjExists = False
                    For j = 1 To .CurrentRegion.Rows.Count - 1
                        If .Offset(j, 0) = strProject Then
                            BlnProjExists = True
                            Exit For
                        End If
                    Next j
                        If BlnProjExists = False Then
                           .Offset(j, 0) = strProject
                        End If
            End If
            Select Case Format(RDate, "mmm yy")
                Case "Apr 13"
                    m = 1
                Case "May 13"
                    m = 2
                Case "Jun 13"
                    m = 3
                Case "Jul 13"
                    m = 4
                Case "Aug 13"
                    m = 5
                Case "Sep 13"
                    m = 6
                Case "Oct 13"
                    m = 7
                Case "Nov 13"
                    m = 8
                Case "Dec 13"
                    m = 9
                Case "Jan 14"
                    m = 10
                Case "Feb 14"
                    m = 11
                Case "Mar 14"
                    m = 12
            End Select
              .Offset(j, m) = .Offset(j, m) + RVal
        End With


     ElseIf InStr(.Offset(i, 0), "OVH") > 0 And RVal > 0 Then
        strProject = .Offset(i, -1)
        With OH.Range("B3")
            If .CurrentRegion.Rows.Count = 1 Then
                .Offset(1, 0) = strProject
                j = 1
            Else
                BlnProjExists = False
                For j = 1 To .CurrentRegion.Rows.Count - 1
                    If .Offset(j, 0) = strProject Then
                        BlnProjExists = True
                        Exit For
                    End If
                Next j
                    If BlnProjExists = False Then
                      .Offset(j, 0) = strProject
                    End If
            End If
            Select Case Format(RDate, "mmm yy")
                Case "Apr 13"
                    m = 1
                Case "May 13"
                    m = 2
                Case "Jun 13"
                    m = 3
                Case "Jul 13"
                    m = 4
                Case "Aug 13"
                    m = 5
                Case "Sep 13"
                    m = 6
                Case "Oct 13"
                    m = 7
                Case "Nov 13"
                    m = 8
                Case "Dec 13"
                    m = 9
                Case "Jan 14"
                    m = 10
                Case "Feb 14"
                    m = 11
                Case "Mar 14"
                    m = 12
            End Select
             .Offset(j, m) = .Offset(j, m) + RVal
        End With
     End If
    Next i
End With
 Application.ScreenUpdating = True
End Sub

Many thanks and kind regards