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

BusinessHack

New Member
Joined
Apr 10, 2016
Messages
7
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
ABCDEFGHIJKLMNOPQRSTUVWXYZAAAB
1BusinessABCAisleAstro BoyBYOCanadian StarsEnforceFridayGoodluckHondaJA RuleJolly SantaLaneLegLong ReachPraiseQ TipsRAP GroupRNBSelectaSolataireStay PowerSundaySungrassTetris PlayerTrinadadWindowZebra
2Company A
3Company B
4Company C
5Company D
Install
 

Excel Facts

Can you sort left to right?
To sort left-to-right, use the Sort dialog box. Click Options. Choose "Sort left to right"
Sorry I forgot to add the second sheet.

Book2
ABCDEFGHIJKLMNOPQRSTUVWXYZAAAB
1BusinessABCAisleAstro BoyBYOCanadian StarsEnforceFridayGoodluckHondaJA RuleJolly SantaLaneLegLong ReachPraiseQ TipsRAP GroupRNBSelectaSolataireStay PowerSundaySungrassTetris PlayerTrinadadWindowZebra
2Company A
3Company B
4Company C
5Company D
Install
 
Upvote 0
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
ABCDEFGHIJKLMNOPQRSTUVWXYZAAAB
1BusinessABCAisleAstro BoyBYOCanadian StarsEnforceFridayGoodluckHondaJA RuleJolly SantaLaneLegLong ReachPraiseQ TipsRAP GroupRNBSelectaSolataireStay PowerSundaySungrassTetris PlayerTrinadadWindowZebra
2Company A
3Company B
4Company C
5Company D
Install
Book2
Install
[XD][/XD]
Book2
ABCDEFGHIJKLMNO
1Business1234567891011121314
2Company ACanadian StarsJA RuleJolly SantaABCRAP GroupTrinadadEnforceFridayGoodluckRNBStay PowerSungrassBYOTetris Player
3Company BQ TipsRAP GroupTrinadadFridaySelectaSolataireSundayBYOHome BeachTetris Player
4Company CAstro BoyJolly SantaQ TipsTrinadadEnforceFridayHondaSmileSolataireSundayZebraEnforceHome BeachTetris Player
5Company DCanadian StarsLong ReachQ TipsSundayWindowABCFridayGoodluckSolataireSundayBYOLegTetris Player
Worked


Sorry this is the First sheet.
 
Upvote 0
I'm not 100% following what you want, but see if this is heading in the right direction (just confirm the sheet names).
VBA Code:
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
ABCDEFGHIJKLMNOPQRSTUVWXYZAAAB
1BusinessABCAisleAstro BoyBYOCanadian StarsEnforceFridayGoodluckHondaJA RuleJolly SantaLaneLegLong ReachPraiseQ TipsRAP GroupRNBSelectaSolataireStay PowerSundaySungrassTetris PlayerTrinadadWindowZebra
2Company AABCBYOCanadian StarsEnforceFridayGoodluckJA RuleJolly SantaRAP GroupRNBStay PowerSungrassTetris PlayerTrinadad
3Company BBYOFridayQ TipsRAP GroupSelectaSolataireSundayTetris PlayerTrinadad
4Company CAstro BoyEnforceFridayHondaJolly SantaQ TipsSolataireSundayTetris PlayerTrinadadZebra
5Company DABCBYOCanadian StarsFridayGoodluckLegLong ReachQ TipsSolataireSundayTetris PlayerWindow
Install
 
Upvote 0
Solution
I'm not 100% following what you want, but see if this is heading in the right direction (just confirm the sheet names).
VBA Code:
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.
 
Upvote 0
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?
 
Upvote 0
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.

Cell Formulas
RangeFormula
A1:A5A1=Sheet1!A1:A5
B1:AA1B1=TRANSPOSE(SORT(UNIQUE(TOCOL(Sheet1!$B$2:$O$5,1,TRUE))))
B2:AA5B2=FILTER(SORT(UNIQUE(TOCOL(Sheet1!$B2:$O2,1,TRUE))),SORT(UNIQUE(TOCOL(Sheet1!$B2:$O2,1,TRUE)))=Sheet2!B$1,"")
Dynamic array formulas.
 
Upvote 0
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.
VBA Code:
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
 
Upvote 0

Forum statistics

Threads
1,223,227
Messages
6,170,848
Members
452,361
Latest member
d3ad3y3

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top