Copying a row of data from another sheet and pasting it into another sheet into the correct column headings

[BusinessHack]

Hi All,

I had no luck in finding a solution so apologies in advance if this has been asked before.

I have text data in Sheet 1 and need each row to be copied to Sheet 2 under the correct column based on the heading.

The data will not be sorted alphabetically in Sheet 1.
Some cells in Sheet 2 will be blank and every now and then a new column heading will be added.

Thanks in advance.

Book2
	A	B	C	D	E	F	G	H	I	J	K	L	M	N	O	P	Q	R	S	T	U	V	W	X	Y	Z	AA	AB
1	Business	ABC	Aisle	Astro Boy	BYO	Canadian Stars	Enforce	Friday	Goodluck	Honda	JA Rule	Jolly Santa	Lane	Leg	Long Reach	Praise	Q Tips	RAP Group	RNB	Selecta	Solataire	Stay Power	Sunday	Sungrass	Tetris Player	Trinadad	Window	Zebra
2	Company A
3	Company B
4	Company C
5	Company D
Install

 

[BusinessHack]

Sorry I forgot to add the second sheet.

Book2
	A	B	C	D	E	F	G	H	I	J	K	L	M	N	O	P	Q	R	S	T	U	V	W	X	Y	Z	AA	AB
1	Business	ABC	Aisle	Astro Boy	BYO	Canadian Stars	Enforce	Friday	Goodluck	Honda	JA Rule	Jolly Santa	Lane	Leg	Long Reach	Praise	Q Tips	RAP Group	RNB	Selecta	Solataire	Stay Power	Sunday	Sungrass	Tetris Player	Trinadad	Window	Zebra
2	Company A
3	Company B
4	Company C
5	Company D
Install

 

[BusinessHack]

Hi All,

I had no luck in finding a solution so apologies in advance if this has been asked before.

I have text data in Sheet 1 and need each row to be copied to Sheet 2 under the correct column based on the heading.

The data will not be sorted alphabetically in Sheet 1.
Some cells in Sheet 2 will be blank and every now and then a new column heading will be added.

Thanks in advance.

Book2
	A	B	C	D	E	F	G	H	I	J	K	L	M	N	O	P	Q	R	S	T	U	V	W	X	Y	Z	AA	AB
1	Business	ABC	Aisle	Astro Boy	BYO	Canadian Stars	Enforce	Friday	Goodluck	Honda	JA Rule	Jolly Santa	Lane	Leg	Long Reach	Praise	Q Tips	RAP Group	RNB	Selecta	Solataire	Stay Power	Sunday	Sungrass	Tetris Player	Trinadad	Window	Zebra
2	Company A
3	Company B
4	Company C
5	Company D
Install

Book2
Install

[XD][/XD]

Book2
	A	B	C	D	E	F	G	H	I	J	K	L	M	N	O
1	Business	1	2	3	4	5	6	7	8	9	10	11	12	13	14
2	Company A	Canadian Stars	JA Rule	Jolly Santa	ABC	RAP Group	Trinadad	Enforce	Friday	Goodluck	RNB	Stay Power	Sungrass	BYO	Tetris Player
3	Company B	Q Tips	RAP Group	Trinadad	Friday	Selecta	Solataire	Sunday	BYO	Home Beach	Tetris Player
4	Company C	Astro Boy	Jolly Santa	Q Tips	Trinadad	Enforce	Friday	Honda	Smile	Solataire	Sunday	Zebra	Enforce	Home Beach	Tetris Player
5	Company D	Canadian Stars	Long Reach	Q Tips	Sunday	Window	ABC	Friday	Goodluck	Solataire	Sunday	BYO	Leg	Tetris Player
Worked

Sorry this is the First sheet.

 

[kevin9999]

I'm not 100% following what you want, but see if this is heading in the right direction (just confirm the sheet names).

Option Explicit
Sub BusHack()
    Dim ws1 As Worksheet, ws2 As Worksheet
    Set ws1 = Worksheets("Worked")
    Set ws2 = Worksheets("Install")
    Dim a, b, c, LRow As Long, LCol As Long, i As Long, j As Long
    
    a = ws2.Range("B1").Resize(1, ws2.Cells(1, 1).CurrentRegion.Columns.Count)
    ws2.UsedRange.Offset(1).ClearContents
    LRow = ws1.Cells(Rows.Count, 1).End(xlUp).Row
    LCol = ws1.Cells.Find("*", , xlFormulas, , 2, 2).Column
    
    ReDim c(1 To LRow - 1, 1 To UBound(a, 2) + 1)
    ws1.Activate
    For i = 1 To UBound(c, 1)
        c(i, 1) = ws1.Cells(i + 1, 1)
        b = ws1.Range(Cells(i + 1, 2), ws1.Cells(i + 1, LCol))
        For j = 1 To UBound(a, 2)
            If IsError(Application.Match(a(1, j), b, 0)) Then
                c(i, j + 1) = ""
            Else
                c(i, j + 1) = a(1, j)
            End If
        Next j
    Next i
    ws2.Range("A2").Resize(UBound(c, 1), UBound(c, 2)).Value = c
End Sub

Install sheet after running the code (is this it?)

Business Hack.xlsm
	A	B	C	D	E	F	G	H	I	J	K	L	M	N	O	P	Q	R	S	T	U	V	W	X	Y	Z	AA	AB
1	Business	ABC	Aisle	Astro Boy	BYO	Canadian Stars	Enforce	Friday	Goodluck	Honda	JA Rule	Jolly Santa	Lane	Leg	Long Reach	Praise	Q Tips	RAP Group	RNB	Selecta	Solataire	Stay Power	Sunday	Sungrass	Tetris Player	Trinadad	Window	Zebra
2	Company A	ABC			BYO	Canadian Stars	Enforce	Friday	Goodluck		JA Rule	Jolly Santa						RAP Group	RNB			Stay Power		Sungrass	Tetris Player	Trinadad
3	Company B				BYO			Friday									Q Tips	RAP Group		Selecta	Solataire		Sunday		Tetris Player	Trinadad
4	Company C			Astro Boy			Enforce	Friday		Honda		Jolly Santa					Q Tips				Solataire		Sunday		Tetris Player	Trinadad		Zebra
5	Company D	ABC			BYO	Canadian Stars		Friday	Goodluck					Leg	Long Reach		Q Tips				Solataire		Sunday		Tetris Player		Window
Install

 

[BusinessHack]

I'm not 100% following what you want, but see if this is heading in the right direction (just confirm the sheet names).

Option Explicit
Sub BusHack()
    Dim ws1 As Worksheet, ws2 As Worksheet
    Set ws1 = Worksheets("Worked")
    Set ws2 = Worksheets("Install")
    Dim a, b, c, LRow As Long, LCol As Long, i As Long, j As Long
   
    a = ws2.Range("B1").Resize(1, ws2.Cells(1, 1).CurrentRegion.Columns.Count)
    ws2.UsedRange.Offset(1).ClearContents
    LRow = ws1.Cells(Rows.Count, 1).End(xlUp).Row
    LCol = ws1.Cells.Find("*", , xlFormulas, , 2, 2).Column
   
    ReDim c(1 To LRow - 1, 1 To UBound(a, 2) + 1)
    ws1.Activate
    For i = 1 To UBound(c, 1)
        c(i, 1) = ws1.Cells(i + 1, 1)
        b = ws1.Range(Cells(i + 1, 2), ws1.Cells(i + 1, LCol))
        For j = 1 To UBound(a, 2)
            If IsError(Application.Match(a(1, j), b, 0)) Then
                c(i, j + 1) = ""
            Else
                c(i, j + 1) = a(1, j)
            End If
        Next j
    Next i
    ws2.Range("A2").Resize(UBound(c, 1), UBound(c, 2)).Value = c
End Sub

Install sheet after running the code (is this it?)

Thanks, it works great. I was using a very long nested IF statement. Sorry about the unclear question, I did not know how to phrase it correctly.

There is a small issue, it won't let me know if there is a new product (or misspelt product) in the first worksheet and there is no matching column heading in the second sheet for it to be copied to.
is it possible to add a warning or error if this happens?

Thanks Again.

 

[kevin9999]

Thanks, it works great. I was using a very long nested IF statement. Sorry about the unclear question, I did not know how to phrase it correctly.

There is a small issue, it won't let me know if there is a new product (or misspelt product) in the first worksheet and there is no matching column heading in the second sheet for it to be copied to.
is it possible to add a warning or error if this happens?

Thanks Again.

I can look at this tomorrow (the code actually works the other way around - it looks for the headers from the second sheet and places them if they're found on the first sheet). How would you want to be informed about new/misspelt products?

 

[Herakles]

Thanks, it works great. I was using a very long nested IF statement. Sorry about the unclear question, I did not know how to phrase it correctly.

There is a small issue, it won't let me know if there is a new product (or misspelt product) in the first worksheet and there is no matching column heading in the second sheet for it to be copied to.
is it possible to add a warning or error if this happens?

Thanks Again.

This will sort this problem out.

It takes its feed from Sheet1 so a list of headings in Sheet2 is dynamically calculated.

Copying a row of data from another sheet and pasting.xlsm
	A	B	C	D	E	F	G	H	I	J	K	L	M	N	O	P	Q	R	S	T	U	V	W	X	Y	Z	AA
1	Business	ABC	Astro Boy	BYO	Canadian Stars	Enforce	Friday	Goodluck	Home Beach	Honda	JA Rule	Jolly Santa	Leg	Long Reach	Q Tips	RAP Group	RNB	Selecta	Smile	Solataire	Stay Power	Sunday	Sungrass	Tetris Player	Trinadad	Window	Zebra
2	Company A	ABC		BYO	Canadian Stars	Enforce	Friday	Goodluck			JA Rule	Jolly Santa				RAP Group	RNB				Stay Power		Sungrass	Tetris Player	Trinadad
3	Company B			BYO			Friday		Home Beach						Q Tips	RAP Group		Selecta		Solataire		Sunday		Tetris Player	Trinadad
4	Company C		Astro Boy			Enforce	Friday		Home Beach	Honda		Jolly Santa			Q Tips				Smile	Solataire		Sunday		Tetris Player	Trinadad		Zebra
5	Company D	ABC		BYO	Canadian Stars		Friday	Goodluck					Leg	Long Reach	Q Tips					Solataire		Sunday		Tetris Player		Window
6
Sheet2

Cell Formulas
Range	Formula
A1:A5	A1	=Sheet1!A1:A5
B1:AA1	B1	=TRANSPOSE(SORT(UNIQUE(TOCOL(Sheet1!$B$2:$O$5,1,TRUE))))
B2:AA5	B2	=FILTER(SORT(UNIQUE(TOCOL(Sheet1!$B2:$O2,1,TRUE))),SORT(UNIQUE(TOCOL(Sheet1!$B2:$O2,1,TRUE)))=Sheet2!B$1,"")
Dynamic array formulas.

 

[BusinessHack]

T

This will sort this problem out.

It takes its feed from Sheet1 so a list of headings in Sheet2 is dynamically calculated.

Thanks, much appreciated

 

[kevin9999]

Try the following. It tests for products either misspelt or missing from sheet 3 & doesn't allow the copy to proceed unless the error is corrected. You get a message telling you what the rogue product is.

Option Explicit
Sub BusHack_2()
    Application.ScreenUpdating = False
    Dim ws1 As Worksheet, ws2 As Worksheet, r As Range
    Set ws1 = Worksheets("Worked")
    Set ws2 = Worksheets("Install")
    Dim a, b, c, d, LRow As Long, LCol As Long, i As Long, j As Long
    
    a = ws2.Range("B1").Resize(1, ws2.Cells(1, 1).CurrentRegion.Columns.Count)
    Set r = ws1.Cells(1, 1).CurrentRegion.Offset(1, 1) '.Resize(Rows.Count - 1)
    d = WorksheetFunction.Unique(r)
    
    For i = LBound(d, 1) To UBound(d, 1)
        For j = LBound(d, 2) To UBound(d, 2)
            If d(i, j) <> "" And IsError(Application.Match(d(i, j), a, 0)) Then
                MsgBox "The product " & d(i, j) & " was not found on sheet 3"
                Exit Sub
            End If
        Next j
    Next i
    
    ws2.UsedRange.Offset(1).ClearContents
    LRow = ws1.Cells(Rows.Count, 1).End(xlUp).Row
    LCol = ws1.Cells.Find("*", , xlFormulas, , 2, 2).Column
    
    ReDim c(1 To LRow - 1, 1 To UBound(a, 2) + 1)
    ws1.Activate
    For i = 1 To UBound(c, 1)
        c(i, 1) = ws1.Cells(i + 1, 1)
        b = ws1.Range(Cells(i + 1, 2), ws1.Cells(i + 1, LCol))
        For j = 1 To UBound(a, 2)
            If IsError(Application.Match(a(1, j), b, 0)) Then
                c(i, j + 1) = ""
            Else
                c(i, j + 1) = a(1, j)
            End If
        Next j
    Next i
    ws2.Range("A2").Resize(UBound(c, 1), UBound(c, 2)).Value = c
    Application.Goto ws2.Range("A1")
    Application.ScreenUpdating = True
End Sub