Hi, I wonder whether someone may be able to help me please.
I'm using the script below to copy data from one 'Source' sheet ("All Data"), creating a unique distinct list and pasting the values to several 'Destination' sheets.
Code:
Sub Extract()
Dim i As Long, j As Long, m As Long, strProject As String, RLOB As String, RDate As Date, RVal As Single
Dim BlnProjExists As Boolean, ws As Worksheet, DI As Worksheet, EH As Worksheet, IND As Worksheet, OVH As Worksheet, PRO As Worksheet, LastRow As Long
Const StartRow As Long = 5
Application.ScreenUpdating = False
Set DI = Sheets("Direct Activities")
Set EH = Sheets("Enhancements")
Set IND = Sheets("Indirect Activities")
Set OH = Sheets("Overheads")
Set PRO = Sheets("Projects")
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)
RLOB = .Offset(i, -3)
If InStr(.Offset(i, 0), "Enhancements") > 0 And RVal > 0 Then
strProject = .Offset(i, 0)
With EH.Range("B1")
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), "DIR") > 0 And RVal > 0 Then
strProject = .Offset(i, -1)
With DI.Range("B1")
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), "IND") > 0 And RVal > 0 Then
strProject = .Offset(i, -1)
With IND.Range("B1")
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("B1")
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), "DIR") + InStr(.Offset(i, 0), "Enhancements") + InStr(.Offset(i, 0), "IND") + InStr(.Offset(i, 0), "OVH") = 0 And RVal > 0 Then
strProject = .Offset(i, 0)
With PRO.Range("B1")
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
For Each ws In Worksheets(Array("Direct Activities", "Enhancements", "Indirect Activities", "Overheads", "Projects"))
LastRow = ws.Cells(Rows.Count, "B").End(xlUp).Row
If LastRow >= StartRow Then
ws.Range("B5:B" & LastRow).NumberFormat = "@"
ws.Range("C5:P" & LastRow).NumberFormat = "0.00"
ws.Range("C5:P" & LastRow).HorizontalAlignment = xlCenter
ws.Range("O5:P" & LastRow).Font.Bold = True
ws.Range("O5:O" & LastRow).FormulaR1C1 = "=Sum(RC3:RC14)/24"
ws.Range("P5:P" & LastRow).FormulaR1C1 = "=RC15/7.24"
End If
ws.Columns("B:Q").AutoFit
Next ws
Application.ScreenUpdating = True
End Sub
To be more specific, the script looks at column E of the' Source' sheet for a number of differing values which are "DIR", "Enhancements", "IND", "OVH" and finally any value which
is not the aforementioned 4 values.
DIR
When this value is found in column E, the script moves one column to the left, copies the value creates a unique distinct list for values with multiple occurrences and pastes this to the "Direct Activities" sheet.
In addition, it also sums a 'Man hour' figure from column
I of the 'Source' sheet and pastes these figures under the relevant monthly heading.
Enhancements
When this value is found in column E, the script copies the value creates a unique distinct list for values with multiple occurrences and pastes this to the "Enhancements" 'Destination sheet.
As before the script sums a 'Man hour' figure from column
I of the 'Source' sheet and pastes these figures under the relevant monthly heading on the 'Enhancements" 'Destination' sheet.
IND
When this value is found in column E, the script moves one column to the left, copies the value creates a unique distinct list for values with multiple occurrences and pastes this to the "Indirect Activities" sheet.
As with the other two values a 'Man hour' figure is summed from column
I of the 'Source' sheet and pastes these figures under the relevant monthly heading.
OVH
When this value is found in column E, the script moves one column to the left, copies the value creates a unique distinct list for values with multiple occurrences and pastes this to the "Overheads" sheet.
Again, in addition a 'Man hour' figure is summed from column
I of the 'Source' sheet and pastes these figures under the relevant monthly heading.
Projects
This element of the script is a little different. When a value which
does not equal "DIR", "Enhancements", "IND" or "OVH" value is found in column E, the script copies the value creates a unique distinct list for values with multiple occurrences and pastes this to the "Projects" 'Destination sheet.
Again, the the script also sums a 'Man hour' figure from column
I of the 'Source' sheet and pastes these figures under the relevant monthly heading on the "Projects" 'Destination' sheet.
I'd now like to change this, so instead of the unique list being created on just one column, I'd like this to occur on multiple columns, but still keep the functionality which sums the 'Man hour' figure.
DIR
When this value is found in column E, I'd like to create the unique distinct lists using the value in columns "
D" and "
B" from the 'Source' sheet, pasting this information into columns "
B" and "
C" on the 'Direct Activities in addition to the summed 'Man hour' figure'.
Enhancements
When this value is found in column E, I'd like to create the unique distinct lists using the value in columns "
E" and "
B" from the 'Source' sheet, pasting this information into columns "
B" and "
C" in addition to the summed 'Man hour' figure'.
IND
When this value is found in column E, I'd like to create the unique distinct lists using the value in columns "
D" and "
B" from the 'Source' sheet, pasting this information into columns "
B" and "
C" in addition to the summed 'Man hour' figure'.
OVH
When this value is found in column E, I'd like to create the unique distinct lists using the value in columns "
D" and "
B" from the 'Source' sheet, pasting this information into columns "
B" and "
C" in addition to the summed 'Man hour' figure'.
Projects
Again,as before I'd like to still search for the values which
does not equal "DIR", "Enhancements", "IND" or "OVH" value is found in column E, but I'd like to create the unique distinct lists using the value in columns "
E" and "
B" and
F from the 'Source' sheet, pasting this information into columns "
B" and "
C" and
D, in addition to the summed 'Man hour' figure'.
I've been trying for some time now to make the changes as above, but without any luck.
I just wondered whether someone may be able to look at this please and offer some guidance on how I may go about achieving this.
I appreciate that this is a long post with a lot of detail, so please find the link to the file here
https://www.dropbox.com/s/5xjqno4fzm...%20Module.xlsm which may perhaps illustrate the current and desired functionality a little better than my explanation.
I have set up the "All Data" source sheet, and then the 'Destination' sheets which are pertinent to the current script. If you click on the button on the "Macros" sheet, you can run the macro.
In addition, I have also included the sheets which show how I'd like the information to be extracted using the revised code. These are shown as "....Output"
Many thanks and kind regards
VBA Extract & Paste
