VBA Copy Specific Cells To Specific Sheets - vba

Question

I was wondering whether someone may be able to help me please.
I'm using the code below to copy data from one sheet to another upon specfic cell values being found.
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
The code works, but I've been trying to adapt a section of this script which I'm having a real difficulty in doing.
The piece of the script which I need to change is as below:
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
In it's current format, if the text values of "Enhancements" or "OVH" are found the data is copied and pasted to the "Enhancements" sheet.
I'd like to change this, so if the text value "Enhancements" is found the information is pasted to the "Enhancements" page and if the text value of "OVH" is found, the information is pasted into the "Overheads" sheet. The rest of the code can remain as it is.
As I say I've tried to make the changes but I seem to fall foul to errors surrounding the use of the 'If', ElseIf' and 'Else' statements.
I just wondered whether someone may be able to look at this please and let me know where I'm going wrong.

Answer 1

I ended up rewriting a lot of your code to make it more efficient, this should accomplish what you're looking for, and it should run rather quickly also:
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

Answer 2

Your sample data is a little confusing, I have presumed that on the overheads sheet you want the overheads code to be from the task column. For the enhancements you want the code to be the project name.
If that's is incorrect, please provide better sample data.
Try this code:
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
Commented version:
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