Find matching columns/cells and copying over data

[Hamond]

Hello,

I developed some code but need some help in tweaking it (or re-wrtting parts if needed). Basically I want to a copy cells from a column in one sheet to columns in another sheet via cross matching column headers to define the column to paste to.

My setup is the following:

In the first sheet (Sourcedata) I have columns of data. Row 2 in Columns B to Y contains a list of Column Headings that I want to find in row 1 of another sheet called "destination".

For each column header in the sourcdata worksheet (Row 2), I want to find the equivalent column header in the destination sheet (row 1). I then want to copy rows 1, 3,4 and paste into row 2 onwards. And then do the same for the next column in sourcedata sheet.

So for example if:

Sourcedata sheet, B2 = Jason
Destination sheet F1 = jason

Then I want to copy B1, B3, B4 and place in F2, F3 and F4. (done via the union command below).

Most of the code is written below (probably not the most efficient!) and works on the whole but not completely. Not all columns will have a match, there will be instances where there are columns/headers that are unique to each sheet and thus do not match, these need to be ignored.

Curently the code can't handle these and I need something to tell it to ignore a column/heading in the source sheet if there is no match with a column in the destination sheet.

Hamond


Sub match()
Application.ScreenUpdating = False
Sheets("sourcedata").Select
lastxvar = Range("B1").End(xlToRight).Column

For i = 2 To lastxvar
Cells(2, i).Select
x = ActiveCell.Value
FindString = x

Union(Range(Cells(1, i), Cells(1, i)), Range(Cells(3, i), Cells(4, i))).Copy
Sheets("desination").Select
Cells.Find(What:=FindString, After:=ActiveCell, LookIn:=xlValues, _
LookAt:=xlWhole, SearchOrder:=xlByColumns, SearchDirection:=xlNext, _
MatchCase:=True, SearchFormat:=False).Select
col = ActiveCell.Column

'Paste here
Cells(2, col).Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Sheets("Sourcedata").Select
Next i
End Sub


I need to adjust the code so that it only pastes (or copies) if a match has been found, where there is no match between the two sheets, that column in sourcedata should be ignored.

Hope someone can help me out as have spent ages trying to fix it but with no luck!

Thanks,

Hamond

[Bob Phillips]

Sub match()

Application.ScreenUpdating = False

With Worksheets("sourcedata")

lastxvar = .Range("B1").End(xlToRight).Column

For i = 2 To lastxvar

x = .Cells(2, i).Value

findcol = 0
On Error Resume Next
findcol = Application.match(x, Worksheets("Destination").Rows(1), 0)
On Error GoTo 0
If Not IsError(findcol) Then

.Cells(1, i).Copy Worksheets("Destination").Cells(2, findcol)
.Cells(3, i).Copy Worksheets("Destination").Cells(3, findcol)
.Cells(4, i).Copy Worksheets("Destination").Cells(4, findcol)
End If
Next i
End With
End Sub