Copy row data from one workbook to another based on row header name

[shettyrish]

I have created a table mapping the row names in my Destination workbook to row names in my source sheet in the sheet named 'Test'.
The mapping is in columns A and B respectively. Column A has the destination sheet row names while column B has source sheet row header names.
I have attached the image.

The destination rows are not successive and there are other rows in between not referring data from the source sheet. The row names in the source sheet are in Column 2 and row names in Destination sheet are in column 1. I need to copy the data from the source sheet rows that have the matching name in the Destination sheet rows as per my mapping from the image attached.

This is my code:


Sub Map()

DestName = "Data Cost Estimate" 'Name of destination sheet
SourceName = "EST Actuals" 'Name of Source sheet
MyDir = "Default directory path"

With Application
.ScreenUpdating = False
.DisplayAlerts = False
.Calculation = xlCalculationManual
End With

Set Wb = ThisWorkbook
Set HeadWS = Wb.Worksheets("Test")
With HeadWS
LastHead = .Cells(.Rows.Count, 1).End(xlUp).Row
Set HeadRange = .Range("A2:A" & LastHead)
ReDim Heads(LastHead - 2) '-1 for header row in header map and -1 for 0 based arrary
Heads = HeadRange.Value
End With

answer = MsgBox("If you want to select a specific file click Yes, if you want to go to default path and If you are not sure, click Cancel", vbYesCancel + vbQuestion, "User Specified Path")

If answer = vbYes Then
MyFile = Application.GetOpenFilename(FileFilter:="Excel Files,*.xl*;*.xm*")
Set wkb = Workbooks.Open(MyFile, UpdateLinks:=0)
With wkb.Worksheets(SourceName)
.Rows("1:" & HeadRow - 1).EntireRow.Delete
For j = .Cells(1, .Columns.Count).End(xlToLeft).Column To 1 Step -1
If IsError(Application.Match(.Cells(1, j), Heads, False)) Then
.Columns(j).Delete
Next

HeadRange.Offset(, 1).Copy
.Range("A1").PasteSpecial Paste:=xlPasteAll, Transpose:=True
End With

ElseIf answer = vbCancel Then
Msgbox "Do nothing"
Exit Sub
End If

With Application
.CutCopyMode = False
.Calculation = xlCalculationAutomatic
End With

ThisWorkbook.Save
End Sub

My code isn't working and I think it would be easier if I write a function for this process, but I am not sure as to how. The table mapping is in columns A and B respectively. Thank you

[SamT]

Your code does not match the textual description of what the issue is.
ie, your code merely deletes a bunch of Columns and pastes transposed one Row to a Column. No other Rows are referred to in the code. No references to any Column Names as listed in the attached image.

BTW, a Function Returns a value and is usually on the RH side of an equals sign,
X = SomeFunction(SomeValue)


HeadRow has no value assigned, Your Code:
.Rows("1:" & HeadRow - 1).EntireRow.Delete

If without End If:
If IsError(Application.Match(.Cells(1, j), Heads, False)) Then
.Columns(j).Delete


ScreenUpdating not turned on
With Application
.CutCopyMode = False
.Calculation = xlCalculationAutomatic
End With

[shettyrish]

Thank you for the corrections SamT. Is there any way you could help me out with this? It would be much appreciated. Thank you

[shettyrish]

I have 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 snipped of my updated code :

Dim initial As String


initial = GetMap(GetRow(wkb.Sheets(SourceName)))

j = Wb.Sheets(DestName).Cells(1, 1).EntireColumn.Find(What:=initial, LookIn:=xlValues, LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False).Row

Call CopyRange(Sheets(SourceName).Range("C12:R12"), Wb.Sheets(DestName).Cells(j, 2), completed)
completed = completed + (100 / steps)

Call CopyRange(Sheets(SourceName).Range("C22:R22"), Wb.Sheets(DestName).Cells(j, 2), completed)
completed = completed + (100 / steps)

Call CopyRange(Sheets(SourceName).Range("C17:R17"), Wb.Sheets(DestName).Cells(j, 2), completed)
completed = completed + (100 / steps)

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)

Call CopyRange(Sheets(SourceName).Range("C30:R30"), Wb.Sheets(DestName).Cells(j, 2), completed)
completed = completed + (100 / steps)

Call CopyRange(Sheets(SourceName).Range("C31:R31"), Wb.Sheets(DestName).Cells(j, 2), completed)
completed = completed + (100 / steps)

Call CopyRange(Sheets(SourceName).Range("C32:R32"), Wb.Sheets(DestName).Cells(j, 2), completed)
completed = completed + (100 / steps)

Call CopyRange(Sheets(SourceName).Range("C36:R36"), Wb.Sheets(DestName).Cells(j, 2), completed)
completed = completed + (100 / steps)

Call CopyRange(Sheets(SourceName).Range("C38:R38"), Wb.Sheets(DestName).Cells(j, 2), completed)
completed = completed + (100 / steps)

wkb.Close


When I try the code, I get an error saying "Object doesn't support this property" for the part where I want the fucntion to return a value. I can't figure out how to correct this. Sorry, I am new to VBA.

[shettyrish]

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 snippet of my updated code :

Dim initial As String


initial = GetMap(GetRow(wkb.Sheets(SourceName)))

j = Wb.Sheets(DestName).Cells(1, 1).EntireColumn.Find(What:=initial, 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


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. Sorry, I am new to VBA. Any help would be appreciated.21441

[offthelip]

What are you actually trying to do? Are you trying to copy all the rows in each column as specified in "Sourcecolumn" on worksheet as specifid by the name or number in sourcename to the columns specified in "Destcolumn on the "Destname" worksheet. You haven't given us all the information.

[shettyrish]

What I need to do is: Search for the given term in the 2nd column of my mapping table in the source sheet, copy the row data of that term and populate the row in my destination sheet in which the 1st term is mapped to the source sheet term in my table. Eg: If the source sheet row header is 'Offer', I need to get that row data and populate the row labeled 'Offer#' in my destination workbook. Thank you.

This is my entire Updated code for better understanding:

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

What I need to do is: Search for the given term in the 2nd column of my mapping table in the source sheet, copy the row data of that term and populate the row in my destination sheet in which the 1st term is mapped to the source sheet term in my table. Eg: If the source sheet row header is 'Offer', I need to get that row data and populate the row labeled 'Offer#' in my destination workbook. Thank you

[offthelip]

I really don't have any better idea of what you are trying to do, but this code will copy the data from the "source" worksheet to column B onwards of the "Dest" worksheet, using the table data in columnns A nd B of the " mapping" worksheet to match the data in column A of the source worksheet to the data in Column A of the destination worksheet:
It is a completely different way of doing it compared to what you are trying to do, but it will be much faster because it accesses the worksheet to a minimum and shows you how to use variant arrays instead of ranges


Sub movedata()Dim outarr As Variant


With Worksheets("Mapping")
lastmap = .Cells(Rows.Count, "A").End(xlUp).Row
Map = Range(.Cells(1, 1), .Cells(lastmap, 2))
End With
With Worksheets("Source")
lastsrow = .Cells(Rows.Count, "A").End(xlUp).Row
inarr = Range(.Cells(1, 1), .Cells(lastsrow, 18))
ReDim outarr(1 To 1, 1 To 18)
End With


With Worksheets("Dest")
lastdrow = .Cells(Rows.Count, "A").End(xlUp).Row
destr = Range(Cells(1, 1), Cells(lastdrow, 1))

' loop round the mapping table
For i = 1 To lastmap
' loop round the source data
For j = 1 To lastsrow
If inarr(j, 1) = Map(i, 2) Then
' we have found the source row header
' loop round the destination data
For k = 1 To lastdrow
If destr(k, 1) = Map(i, 1) Then
'we have found the destination row
' copy a row
For m = 1 To 18
outarr(1, m) = inarr(j, m)
Next m
Range(.Cells(k, 2), .Cells(k, m + 1)) = outarr
End If
Next k
End If
Next j
Next i


End With


End Sub

[SamT]

I am new to VBA.

The basic algorithm you're looking for is:

For each Source Label in Test, Column B
Find Label in Source, Column A, Copy Row From B to R
Find Matching Dest Label in Destination, Column A, Paste in Column B


and you need to handle not finding what you're looking for. The order in which you check for no-finds is a personal choice, But I prefer to check after each search. I also prefer to use VBA functions in code whenever possible and leave WorksheetFunctions to Cell Formulas

There are two basic loop methods in VBA, For and Do. The For method merely means finding the last Row number and
For i = 2 to LastRow
'Do Stuff
Next

The Do method just starts at the top (or bottom, or side) and continues till a blank Cell is arrived at
Do While Cel <> ""
'Do Stuff
Set Cel = Cel.Offset(1,0)
Loop

Obviously, in its simplest form the Do method will fail if there are any empty Cells in the Range to be used. This does not apply in your case

The VBA Find Function is fast and reliable

Set SCel = SrcSht.Range("A:A").Find(Cel)
'And
Set DCel = DestSht.Range("A:A").Find(Cel.Offset(0, -1))

Thus far, we have satisfied the Looping and the finding. Now, we'll satisfy the no-find requirements
'inside the loop
Set SCel = SrcSht.Range("A:A").Find(Cel)
If SCel is Nothing then GoTo LoopEnd 'this particular Row Label was not found/does not exist

Set DCel = DestSht.Range("A:A").Find(Cel.Offset(0, -1)) 'Cel in Col "B," Offset -1 in Col "A"
If DCel is Nothing then GoTo LoopEnd

'Do Stuff

LoopEnd:
Loop

All that is left of the algorithm is the copy and paste. But you need to copy Cells from the right of Column A on the Source sheet and paste to the Right of Column A on the Destination sheet
SCel.OffSet(0, 1).Resize(1, 17).Copy 'Resize Range B to include Column R
DCel.Offset(0, 1).Paste


Putting it all together

Sub VBAX_SamT()
'For help see: http://www.vbaexpress.com/forum/showthread.php?61834
Dim Cel As Range
Dim SCel As Range
Dim DCel As Range

Set Cel = Sheets("NamesListSheet").Range("B2")

'Loop thru the Labels/Names
Do While Cel <> ""

'Find the appropriate Labels/Names
Set SCel = Sheets("SrcSht").Range("A:A").Find(Cel)
'Check Finding
If SCel is Nothing then GoTo LoopEnd

Set DCel = Sheets("DestSht").Range("A:A").Find(Cel.Offset(0, -1))
If DCel is Nothing then GoTo LoopEnd

'Copy and Paste
SCel.OffSet(0, 1).Resize(1, 17).Copy
DCel.Offset(0, 1).Paste

LoopEnd: 'A Code Line Label. Does noting. only a signpost
Set Cel = Cel.Offset(1, 0)
Loop

End Sub

[SamT]

Two threads from the same member on the same question have been merged into one thread

[shettyrish]

Hello SamT and offthelip, the follwing is what I did and it does exactly what I wanted to do, Thank you for your valuable inputs :)

So after a lot of trial and error, 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

For i = 1 To destTotalRows

destKey = DestSheet.Cells(i, 1)
If destKey = "" Then GoTo endFor

sourceKey = GetSourceKey(destKey)
If sourceKey = "" Then GoTo endFor

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

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()


'Application.ScreenUpdating = True
Application.DisplayAlerts = True
'Application.EnableEvents = True
Application.Calculation = xlCalculationAutomatic
ActiveSheet.DisplayPageBreaks = True


End Sub