PDA

View Full Version : [SOLVED] VBA Paste Cells With Specific Text String to Specific Sheet



hobbiton73
08-11-2013, 08:47 AM
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
08-11-2013, 09:10 AM
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
08-11-2013, 09:55 AM
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
08-11-2013, 10:00 AM
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
08-11-2013, 10:22 AM
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
08-11-2013, 11:36 AM
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
08-11-2013, 10:43 PM
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
08-12-2013, 10:20 AM
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
08-12-2013, 10:52 AM
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
08-12-2013, 11:08 AM
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
08-13-2013, 04:14 AM
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
08-17-2013, 10:13 AM
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