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
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
Sub HTH()
Dim rLookup As Range, rFound As Range
Dim lLastRow As Long, lRow As Long
Dim lMonthIndex As Long, lProjectIndex As Long
Dim vData As Variant, vMonths As Variant
Dim iLoop As Integer
Dim vbDict As Object
With Worksheets("AllData")
Set rLookup = .Range("E3", .Cells(Rows.Count, "E").End(xlUp))
Set rFound = .Range("E3")
End With
Set vbDict = CreateObject("Scripting.Dictionary")
vMonths = Array(4, 5, 6, 7, 8, 9, 10, 11, 12, 1, 2, 3)
For iLoop = 0 To 1
lRow = 0: lLastRow = 3
vbDict.RemoveAll: ReDim vData(rLookup.Count, 13)
Do
Set rFound = Worksheets("AllData").Cells.Find(Array("Enhancements", "OVH")(iLoop), _
rFound, , , xlByRows, xlNext, False)
If rFound Is Nothing Then Exit Do
If rFound.Row <= lLastRow Then Exit Do
lMonthIndex = WorksheetFunction.Match(Month(CDate(rFound.Offset(, 4).Value)), vMonths, False)
If vbDict.exists(rFound.Offset(, -iLoop).Value) Then
lProjectIndex = vbDict.Item(rFound.Value)
vData(lProjectIndex, lMonthIndex) = _
vData(lProjectIndex, lMonthIndex) + rFound.Offset(, 4).Value
Else
vbDict.Add rFound.Offset(, -iLoop).Value, lRow
vData(lRow, 0) = rFound.Offset(, -iLoop).Value
vData(lRow, lMonthIndex) = rFound.Offset(, 4).Value
lRow = lRow + 1
End If
lLastRow = rFound.Row
Loop
If iLoop = 0 Then
With Worksheets("Enhancements")
.Range("B4:O" & Rows.Count).ClearContents
.Range("B4").Resize(vbDict.Count + 1, 13).Value = vData
End With
Else
With Worksheets("Overheads")
.Range("B4:O" & Rows.Count).ClearContents
.Range("B4").Resize(vbDict.Count + 1, 13).Value = vData
End With
End If
Next iLoop
End Sub
Sub HTH()
Dim rLookup As Range, rFound As Range
Dim lLastRow As Long, lRow As Long
Dim lMonthIndex As Long, lProjectIndex As Long
Dim vData As Variant, vMonths As Variant
Dim iLoop As Integer
Dim vbDict As Object
'// Get the projects range to loop through
With Worksheets("AllData")
Set rLookup = .Range("E3", .Cells(Rows.Count, "E").End(xlUp))
Set rFound = .Range("E3")
End With
'// Use a latebinded dictionary to store the project names.
Set vbDict = CreateObject("Scripting.Dictionary")
'// Create an array of the months to get the correct columns. Instead of your select case method
vMonths = Array(4, 5, 6, 7, 8, 9, 10, 11, 12, 1, 2, 3)
'// Loop through both search requirements
For iLoop = 0 To 1
'// Set the counters - lLastRow is used to make sure the loop is not never ending.
lRow = 0: lLastRow = 3
'// Clear the dictionary and create the projects array.
vbDict.RemoveAll: ReDim vData(rLookup.Count, 13)
Do
'// Search using the criteria requried
Set rFound = Worksheets("AllData").Cells.Find(Array("Enhancements", "OVH")(iLoop), _
rFound, , , xlByRows, xlNext, False)
'// Make sure something was found and its not a repeat.
If rFound Is Nothing Then Exit Do
If rFound.Row <= lLastRow Then Exit Do
'// Get the correct month column using our months array and the project date.
lMonthIndex = WorksheetFunction.Match(Month(CDate(rFound.Offset(, 4).Value)), vMonths, False)
'// Check if the project exists.
If vbDict.exists(rFound.Offset(, -iLoop).Value) Then
'// Yes it exists so add the actuals to the correct project/month.
lProjectIndex = vbDict.Item(rFound.Value)
vData(lProjectIndex, lMonthIndex) = _
vData(lProjectIndex, lMonthIndex) + rFound.Offset(, 4).Value
Else
'// No it doesnt exist, create it and then add the actuals to the correct project/month
vbDict.Add rFound.Offset(, -iLoop).Value, lRow
vData(lRow, 0) = rFound.Offset(, -iLoop).Value
vData(lRow, lMonthIndex) = rFound.Offset(, 4).Value
'// Increase the project count.
lRow = lRow + 1
End If
'// Set the last row = the last found row to ensure we dont repeat the search.
lLastRow = rFound.Row
Loop
If iLoop = 0 Then
'// Clear the enhancements sheet and populate the cells from the array
With Worksheets("Enhancements")
.Range("B4:O" & Rows.Count).ClearContents
.Range("B4").Resize(vbDict.Count + 1, 13).Value = vData
End With
Else
'// Clear the overheads sheet and populate the cells from the array
With Worksheets("Overheads")
.Range("B4:O" & Rows.Count).ClearContents
.Range("B4").Resize(vbDict.Count + 1, 13).Value = vData
End With
End If
Next iLoop
End Sub
Sub Extract()
Dim cllProjects As Collection
Dim wsData As Worksheet
Dim wsEnha As Worksheet
Dim wsOver As Worksheet
Dim rngFind As Range
Dim rngFound As Range
Dim rngProject As Range
Dim arrProjects() As Variant
Dim varProjectType As Variant
Dim ProjectIndex As Long
Dim cIndex As Long
Dim dRVal As Double
Dim dRDate As Double
Dim strFirst As String
Dim strProjectFirst As String
Dim strProject As String
Set wsData = Sheets("AllData")
Set wsEnha = Sheets("Enhancements")
Set wsOver = Sheets("Overheads")
wsEnha.Range("B4:O" & Rows.Count).ClearContents
wsOver.Range("B4:O" & Rows.Count).ClearContents
With wsData.Range("E4", wsData.Cells(Rows.Count, "E").End(xlUp))
If .Row < 4 Then Exit Sub 'No data
On Error Resume Next
For Each varProjectType In Array("Enhancements", "OVH")
Set cllProjects = New Collection
ProjectIndex = 0
ReDim arrProjects(1 To WorksheetFunction.CountIf(.Cells, "*" & varProjectType & "*"), 1 To 14)
Set rngFound = .Find(varProjectType, .Cells(.Cells.Count), xlValues, xlPart)
If Not rngFound Is Nothing Then
strFirst = rngFound.Address
Do
strProject = vbNullString
dRDate = wsData.Cells(rngFound.Row, "H").Value2
dRVal = wsData.Cells(rngFound.Row, "I").Value2
If varProjectType = "OVH" And dRVal > 0 Then
strProject = wsData.Cells(rngFound.Row, "D").Text
Set rngFind = Intersect(.EntireRow, wsData.Columns("D"))
ElseIf varProjectType = "Enhancements" Then
strProject = wsData.Cells(rngFound.Row, "E").Text
Set rngFind = .Cells
End If
If Len(strProject) > 0 Then
cllProjects.Add LCase(strProject), LCase(strProject)
If cllProjects.Count > ProjectIndex Then
ProjectIndex = cllProjects.Count
arrProjects(ProjectIndex, 1) = strProject
Set rngProject = Intersect(rngFound.EntireRow, Columns(rngFind.Column))
strProjectFirst = rngProject.Address
Do
If LCase(rngProject.Text) = LCase(strProject) Then
dRDate = wsData.Cells(rngProject.Row, "H").Value2
dRVal = wsData.Cells(rngProject.Row, "I").Value2
cIndex = Month(dRDate) - 2 + (Year(dRDate) - 2013) * 12
arrProjects(ProjectIndex, cIndex) = arrProjects(ProjectIndex, cIndex) + dRVal
End If
Set rngProject = rngFind.Find(arrProjects(ProjectIndex, 1), rngProject, xlValues, xlPart)
Loop While rngProject.Address <> strProjectFirst
End If
End If
Set rngFound = .Find(varProjectType, rngFound, xlValues, xlPart)
Loop While rngFound.Address <> strFirst
End If
If cllProjects.Count > 0 Then
Select Case varProjectType
Case "Enhancements": wsEnha.Range("B4").Resize(cllProjects.Count, UBound(arrProjects, 2)).Value = arrProjects
Case "OVH": wsOver.Range("B4").Resize(cllProjects.Count, UBound(arrProjects, 2)).Value = arrProjects
End Select
Set cllProjects = Nothing
End If
Next varProjectType
On Error GoTo 0
End With
Set cllProjects = Nothing
Set wsData = Nothing
Set wsEnha = Nothing
Set wsOver = Nothing
Set rngFound = Nothing
Set rngProject = Nothing
Erase arrProjects
End Sub
