Option Explicit
Sub compData()
Dim wsDs As Worksheet, dsData As Range, ds As Range, budgetData As String
Dim brWbBU As Worksheet, brWbDS As Worksheet, crBU As Range
Application.ScreenUpdating = False
On Error GoTo compData_Error
Set wsDs = ActiveWorkbook.Worksheets("Daily Status")
Set dsData = Find_Range("*", wsDs.Range("C2:C" & wsDs.Cells(Rows.Count, "C").End(xlUp).Row), xlValues, xlWhole)
MsgBox "Open Budget Data Workbook", vbInformation
budgetData = Application.GetOpenFilename("Excel files (*.xls*),*.xls*", _
1, "Select Budget Workbook", , False)
If budgetData <> "False" Then
Workbooks.Open (budgetData)
Else
MsgBox "No Workbook Selected - Process will now end", vbCritical
Exit Sub
End If
On Error Resume Next
Set brWbBU = ActiveWorkbook.Worksheets("Budget Update")
On Error GoTo 0
If brWbBU Is Nothing Then
MsgBox "Opened workbook does not contain Budget Update Sheet. Please open correct file"
Exit Sub
End If
For Each ds In dsData
Set crBU = Find_Range(ds, brWbBU.Range("A9:A" & brWbBU.Cells(Rows.Count, "A").End(xlUp).Row), xlValues, xlWhole)
If Not crBU Is Nothing Then
wsDs.Range(ds.Address).Offset(, 9).Copy
brWbBU.Range(crBU.Address).Offset(, 10).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Else
wsDs.Range(ds.Address).Copy
brWbBU.Range("A" & brWbBU.Cells(Rows.Count, "A").End(xlUp).Row + 1).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
End If
Next
Application.ScreenUpdating = True
On Error GoTo 0
Exit Sub
compData_Error:
MsgBox "Error " & Err.Number & " (" & Err.Description & ") in procedure compData of Module1"
End Sub
Function Find_Range(Find_Item As Variant, _
Search_Range As Range, _
Optional LookIn As Variant, _
Optional LookAt As Variant, _
Optional MatchCase As Boolean) As Range
Dim c As Range, firstAdd As String
If IsMissing(LookIn) Then LookIn = xlValues 'xlFormulas
If IsMissing(LookAt) Then LookAt = xlPart 'xlWhole
If IsMissing(MatchCase) Then MatchCase = False
With Search_Range
Set c = .Find( _
What:=Find_Item, _
LookIn:=LookIn, _
LookAt:=LookAt, _
SearchOrder:=xlByRows, _
SearchDirection:=xlNext, _
MatchCase:=MatchCase, _
SearchFormat:=False)
If Not c Is Nothing Then
Set Find_Range = c
firstAdd = c.Address
Do
Set Find_Range = Union(Find_Range, c)
Set c = .FindNext(c)
Loop While c.Address <> firstAdd
End If
End With
End Function
Bookmarks