Row header mapping to paste data - vba

Question

I have attached the image of my mapping table and written these two functions referring to the mapping table that I created : (Table name is "Automation")
1)
Function GetRow(rowName As String) As String
Dim refRange As Range: Set refRange = Sheet14.Range("Automation")
On Error GoTo errProc
GetRow = WorksheetFunction.VLookup(rowName, refRange, 2, 0)
Exit Function
errProc:
If Err.Number = 1004 Then
Err.Raise "5000", "Something bad happened", "Value " & rowName & " not
found!!"
Else
Err.Raise Err.Number, Err.Source, Err.Description
End If
End Function
2)
Function GetMap(rowName As String) As String
Dim refRange As Range: Set refRange = Sheet14.Range("Automation")
On Error GoTo errProc
GetMap = WorksheetFunction.VLookup(rowName, refRange, 1, 0)
Exit Function
errProc:
If Err.Number = 1004 Then
Err.Raise "5000", "Something bad happened", "Value " & rowName & " not
found!!"
Else
Err.Raise Err.Number, Err.Source, Err.Description
End If
End Function
And this is the entire updated code :
Sub CopyRange(fromRange As Range, toRange As Range, completed As Double)
fromRange.Copy
toRange.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone,
SkipBlanks:=False, Transpose:=False
Application.StatusBar = "Copying In progress..." & Round(completed, 0) & "%
completed"
DoEvents
End Sub
Sub Header()
DestName = "Data Cost Estimate" 'Name of destination sheet
SourceName = "EST Actuals" 'Name of Source sheet
MyDir = "\Path\" 'Default directory path"
Const steps = 22 'Number of rows copied
ref = 13 'row in Estimate sheet in which 'Grand Total' is
present
Set Wb = ThisWorkbook
' disable certain excel features to speed up the process
Application.DisplayAlerts = False
'Application.EnableEvents = False
ActiveSheet.DisplayPageBreaks = False
Application.Calculation = xlCalculationManual
MyFile = Dir(MyDir & "Estimate.xlsm") 'change file extension
ChDir MyDir
Set wkb = Workbooks.Open(MyDir + MyFile, UpdateLinks:=0)
Dim lnCol As Long
Dim last As Long 'Find the last non-blank cell in row 1
lnCol = wkb.Sheets(SourceName).Cells(ref,
Columns.Count).End(xlToLeft).Column
last = lnCol - 1
MsgBox "Last but one column is: " & last
Dim from, dest As String
from = GetRow(GetMap(wkb.Sheets(SourceName)))
j = Wb.Sheets(DestName).Cells(1, 1).EntireColumn.Find(What:=from,
LookIn:=xlValues, LookAt:=xlPart, SearchOrder:=xlByRows,
SearchDirection:=xlNext, MatchCase:=False).Row
Call CopyRange(Sheets(SourceName).Range("C18:R18"),
Wb.Sheets(DestName).Cells(j, 2), completed)
completed = completed + (100 / steps)
Call CopyRange(Sheets(SourceName).Range("C20:R20"),
Wb.Sheets(DestName).Cells(j, 2), completed)
completed = completed + (100 / steps)
Call CopyRange(Sheets(SourceName).Range("C27:R27"),
Wb.Sheets(DestName).Cells(j, 2), completed)
completed = completed + (100 / steps)
wkb.Close
MyFile = Dir()
'Application.ScreenUpdating = True
Application.DisplayAlerts = True
'Application.EnableEvents = True
Application.Calculation = xlCalculationAutomatic
ActiveSheet.DisplayPageBreaks = True
When I try the code, I get an error saying "Object doesn't support this property" for the part where I want the function to return a value. I can't figure out how to correct this. CopyRange is another sub that I use for my Progress bar.

Answer 1

So after a lot of trial and error and help from #tomjohnriddle, here is the function and the correct code:
1) Function:
Function GetSourceKey(destinationKey As String) As String
Dim refRange As Range: Set refRange = Sheet14.Range("Mapping table name")
On Error GoTo errProc
GetSourceKey = WorksheetFunction.VLookup(destinationKey,
ThisWorkbook.Sheets("Sheet name in which mapping table is present").[Mapping table name], 2, 0)
Exit Function
errProc:
If Err.Number = 1004 Then
Err.Raise "5000", "Something bad happened", "Value " & destinationKey & "
not found!!"
Else
Err.Raise Err.Number, Err.Source, Err.Description
End If
End Function
2) Code :
Option Explicit
Sub CopyRange(fromRange As Range, toRange As Range, completed As Double)
fromRange.Copy
toRange.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone,
SkipBlanks:=False, Transpose:=False
Application.StatusBar = "Copying In progress..." & Round(completed, 0) & "%
completed"
DoEvents
End Sub
Sub Header()
DestName = "x" 'Name of destination sheet
SourceName = "y" 'Name of Source sheet
MyDir = "\Path\" 'Default directory path"
Const steps = 22 'Number of rows copied
ref = 13 'row in Estimate sheet in which 'Grand Total' is present
Set DestWb = ThisWorkbook 'Setting Destination workbook
Dim DestSheet As Worksheet
Dim SrcSheet As Worksheet
' disable certain excel features to speed up the process
Application.DisplayAlerts = False
'Application.EnableEvents = False
ActiveSheet.DisplayPageBreaks = False
Application.Calculation = xlCalculationManual
Application.ScreenUpdating = False
MyFile = Dir(MyDir & "Estimate*.xls*") 'change file extension
ChDir MyDir
Set SrcWb = Workbooks.Open(MyDir + MyFile, UpdateLinks:=0)
completed = 0
Application.StatusBar = "Copying In progress..." & Round(completed,
0) & "% completed"
'Find the last non-blank cell in row ref
lnCol = SrcWb.Sheets(SourceName).Cells(ref,
Columns.Count).End(xlToLeft).Column
last = lnCol - 1 'To get penultimate column
Set DestSheet = DestWb.Sheets(DestName)
Set SrcSheet = SrcWb.Sheets(SourceName)
destTotalRows = DestSheet.Cells(Rows.Count, 1).End(xlUp).Row 'Finding last non-blank cell in Column 1 in Destination sheet
MsgBox "Last row is: " & destTotalRows
For i = 1 To destTotalRows
destKey = DestSheet.Cells(i, 1)
If destKey = "" Then GoTo endFor
sourceKey = GetSourceKey(destKey)
If sourceKey = "" Then GoTo endFor
Debug.Print "DestKey", destKey, "SourceKey", sourceKey
k = DestSheet.Cells(1, 1).EntireColumn.Find(What:=destKey, LookIn:=xlValues, LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False).Row
j = SrcSheet.Cells(1, 2).EntireColumn.Find(What:=sourceKey, LookIn:=xlValues, LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False).Row
Debug.Print j, k
Call CopyRange(SrcSheet.Range(Cells(j, 3), Cells(j, 3).End(xlToRight)), DestSheet.Cells(k, 2), completed)
completed = completed + (100 / steps)
endFor:
Next i
SrcWb.Close
Application.StatusBar = "Copying is complete"
DoEvents
MyFile = Dir()
Dim x As Long
'Find the last non-blank cell in row 1
DestColCount = Cells(1, Columns.Count).End(xlToLeft).Column
DestWb.Sheets(DestName).Columns(2).Copy
For x = 3 To DestColCount
Columns(x).PasteSpecial Paste:=xlPasteFormats
Next
'Application.ScreenUpdating = True
Application.DisplayAlerts = True
'Application.EnableEvents = True
Application.Calculation = xlCalculationAutomatic
ActiveSheet.DisplayPageBreaks = True
End Sub