Hi, I wonder whether someone may be able to help me please.
I'm using the script below to extract data from a master "All Data" sheet to multiple 'Destination' sheets, pasting the extracted data on selected rows for each of the sheets
I have to admit I've put this together from several scripts I used, and despite the fact that it works, it's incredibly slow.
Code
'Define Constants to indicate use of OVERHEADS or PROJECTS
Const nUseAllDIR As Integer = 1
Const nUseAllEH As Integer = 2
Const nUseAllIND As Integer = 3
Const nUseAllOVH As Integer = 4
Sub ActivitiesForecasts()
' 'This is the Direct Activities routine
' 'It calls the Direct Activities, Enhancements, Indirect Activities, Overheads and Projects routine with the Indirect Activities option
Call ForecastsExtract(nUseAllDIR)
Call ForecastsExtract(nUseAllEH)
Call ForecastsExtract(nUseAllIND)
Call ForecastsExtract(nUseAllOVH)
End Sub
Sub ForecastsExtract(iOption As Integer)
Dim a
Dim ad As Worksheet
Dim bottomB As Integer
Dim dic As Object
Dim i As Long
Dim Mmonth
Dim rng As Range
Dim ws As Worksheet
Dim Y()
Application.ScreenUpdating = False
Set ad = Sheets("All Data")
bottomB = Range("B" & Rows.Count).End(xlUp).Row
For Each rng In ad.Range("B8:B" & bottomB)
If rng > 0 Then
Set ws = Sheets(rng.Value)
Application.ScreenUpdating = False
With Worksheets("All Data")
a = .Range("B8").CurrentRegion ' Load the required range in to array, named "a"
End With
Set dic = CreateObject("scripting.dictionary")
dic.comparemode = 1
With dic
For i = 2 To UBound(a) ' Loop through rows
Select Case iOption
Case nUseAllDIR
If a(i, 1) = ws.Name And InStr(a(i, 8), "TM - DIR") > 0 Then 'test if column C is "Consultancy & Requirements"
Mmonth = Trim(Format(a(i, 12), "mmm yy")) ' format the date in to mmm-yy
If Not .exists(Mmonth) Then 'If column C cells do not exist, load column E value in to dictionary using column C as item
.Item(Mmonth) = a(i, 14)
Else
.Item(Mmonth) = .Item(Mmonth) + a(i, 14) 'If column C cells do exist, then add column E in to existing item
End If
End If
Case nUseAllEH
If a(i, 1) = ws.Name And InStr(a(i, 8), "Enhancements") > 0 Then 'test if column C is "Consultancy & Requirements"
Mmonth = Trim(Format(a(i, 12), "mmm yy")) ' format the date in to mmm-yy
If Not .exists(Mmonth) Then 'If column C cells do not exist, load column E value in to dictionary using column C as item
.Item(Mmonth) = a(i, 14)
Else
.Item(Mmonth) = .Item(Mmonth) + a(i, 14) 'If column C cells do exist, then add column E in to existing item
End If
End If
Case nUseAllIND
If a(i, 1) = ws.Name And InStr(a(i, 8), "TM - IND") > 0 Then 'test if column C is "Consultancy & Requirements"
Mmonth = Trim(Format(a(i, 12), "mmm yy")) ' format the date in to mmm-yy
If Not .exists(Mmonth) Then 'If column C cells do not exist, load column E value in to dictionary using column C as item
.Item(Mmonth) = a(i, 14)
Else
.Item(Mmonth) = .Item(Mmonth) + a(i, 14) 'If column C cells do exist, then add column E in to existing item
End If
End If
Case nUseAllOVH
If a(i, 1) = ws.Name And InStr(a(i, 8), "TM - OVH") > 0 Then 'test if column C is "Consultancy & Requirements"
Mmonth = Trim(Format(a(i, 12), "mmm yy")) ' format the date in to mmm-yy
If Not .exists(Mmonth) Then 'If column C cells do not exist, load column E value in to dictionary using column C as item
.Item(Mmonth) = a(i, 14)
Else
.Item(Mmonth) = .Item(Mmonth) + a(i, 14) 'If column C cells do exist, then add column E in to existing item
End If
End If
End Select
Next
End With
With ws
a = .Range("C7", .Cells(7, .Columns.Count).End(xlToLeft)) ' Load the required range in to array, named "a"
End With
ReDim Y(1 To 2, 1 To UBound(a, 2))
With dic
For i = 1 To UBound(a, 2) ' Loop through rows
Mmonth = Trim(Format(a(1, i), "mmm yy")) ' format the date in to mmm-yy
If .exists(Mmonth) Then 'If column C cells do exist then copy the the dictionary in to match column
Y(1, i) = .Item(Mmonth)
End If
Next
End With
With ws
'Process either Direct Activities, Enhancements, Indirect Activities, Overheads or PROJECTS for resize
Select Case iOption
'Direct Activities processing resize
Case nUseAllDIR
.Range("C9").Resize(1, i - 1) = Y() 'Result-load Y in to C8
'Enhancements processing resize
Case nUseAllEH
.Range("C10").Resize(1, i - 1) = Y() 'Result-load Y in to C8
'Indirect Activities processing resize
Case nUseAllIND
.Range("C11").Resize(1, i - 1) = Y() 'Result-load Y in to C8
'Overheads processing resize
Case nUseAllOVH
.Range("C12").Resize(1, i - 1) = Y() 'Result-load Y in to C8
End Select
End With
End If
Next rng
Set dic = Nothing ' clear dic
End SubI've been researching 'Select Case' statements over the past few days, but all of the tutorials and examples seem very basic in comparison to what I'm trying to achieve, so I'm very unsure how I can improve this.
I just wondered whether someone could possibly look at this and offer some guidance on how I may go about correcting this problem.
Many thanks and kind regards
Chris