Help, consolidating multiple columns!!

[mbogan]

I need some help with an existing spreadsheet. I want to create a new one which will duplicate 2 rows based off of the data that resides in multiple rows. Here is a sample of what I need:

1st Row is the Header Row.

A1 = Company Name
B1 = Contact Name
C1 = ABC1
D1 = ABC2
E1 = ABC3
F1 = DEF1
G1 = DEF2
H1 = DEF3
I1 = GHI1
J1 = GHI2
K1 = GHI3
(etc..)

I need to consolidate all columns down to 5 (A,B,C,D,E) to get the following new spreadsheet result:

A1 = Company Name
B1 = Name
C1 = Code1
D1 = Code2
E1 = Code3


Example of Sample to Results needed:

SAMPLE data:

ABC Inc,John Doe,ABC1,ABC2,ABC3,DEF1,DEF2,DEF3,GHI1,GHI2,GHI3
XYZ LLC,Joe Smith,ABC1,ABC2,ABC3,DEF1,DEF2,DEF3,GHI1,GHI2,GHI3
etc...

RESULTING data:

ABC Inc, John Doe, ABC1, ABC2, ABC3
ABC Inc, John Doe, DEF1, DEF2, DEF3
ABC Inc, John Doe, GHI1, GHI2, GHI3
XYZ LLC, Joe Smith, ABC1, ABC2, ABC3
XYZ LLC, Joe Smith, DEF1, DEF2, DEF3
XYZ LLC, Joe Smith, GHI1, GHI2, GHI3
etc...

Please help me out. Thank you!!

 

[Norie]

Try the following code.

Sub test()
Dim wsData As Worksheet
Dim wsNew As Worksheet
Dim rng As Range
Dim I As Long
Dim J As Long
Dim arrHeadings

    arrHeadings = Array("Company Name", "Name", "Code1", "Code2", "Code3")

    Set wsData = ActiveSheet
    Set wsNew = Worksheets.Add

    wsNew.Range("A1:E1") = arrHeadings
    I = 2
    
    Set rng = wsData.Range("A2")
    
    While rng.Value <> ""
        
        rng.Resize(, 2).Copy wsNew.Range("A" & I).Resize(3, 2)
        For J = 0 To 2
            rng.Offset(, 2 + (J * 3)).Resize(, 3).Copy wsNew.Range("A" & I).Offset(J, 2)
        Next J
        I = I + 3
        Set rng = rng.Offset(1)
    Wend
End Sub

 

[mbogan]

One other thing and youve got it!!

OK That worked really well, except one thing that needs to be added somehow.

I need to know what each code is, Can you tweak it to add a description column that includes the 1st three charaters of the header row. Since they should all be the same (ie. ABC1, ABC2, ABC3 would all = ABC) it should matter which one is used

Here is an example of what I am referring to:

Example of Sample to Results needed:

SAMPLE data:

Header Row:
Company, Name,ABC1,ABC2,ABC3,DEF1,DEF2,DEF3,GHI1,GHI2,GHI3

Data:
ABC Inc,John Doe,code1,code2,code3,code1,code2,code3,code1,code2,code3
ABC Inc,Joe Smith,code1,code2,code3,code1,code2,code3,code1,code2,code3

RESULTING data:

Header Row:
Company, Name, Description, Code1, Code2, Code3

Data:
ABC Inc, John Doe,ABC, code1,code2,code3
ABC Inc, John Doe,DEF,code1,code2,code3
ABC Inc, John Doe,GHI,code1,code2,code3
XYZ LLC, Joe Smith,ABC,code1,code2,code3
XYZ LLC, Joe Smith,DEF,code1,code2,code3
XYZ LLC, Joe Smith,GHI,code1,code2,code3


For the Description column I want to use the 1st three letters of the header row taht is being used. Example (ABC1 = ABC, or GEF12635 = GEF)

The main purpose would be to identify the dta athat was just rearranged. The codes moved perfectly, but now I do not know what codes they are for. Another option would be to simply put the header row in the column to the right of the Code column (Example Code1, ABC1,Code2,ABC2, Code3, ABC3)

Does that make sense!!

Thanks

 

[Norie]

Try this amended code.

Sub test()
Dim wsData As Worksheet
Dim wsNew As Worksheet
Dim rng As Range
Dim I As Long
Dim J As Long
Dim arrHeadings

    arrHeadings = Array("Company Name", "Name", "Description", "Code1", "Code2", "Code3")

    Set wsData = ActiveSheet
    Set wsNew = Worksheets.Add

    wsNew.Range("A1:F1") = arrHeadings
    I = 2
    
    Set rng = wsData.Range("A2")
    
    While rng.Value <> ""
        
        rng.Resize(, 2).Copy wsNew.Range("A" & I).Resize(3, 2)
        For J = 0 To 2
            wsNew.Range("A" & I).Offset(J, 2) = Left(wsData.Cells(1, rng.Offset(, 2 + (J * 3)).Column), 3)
            rng.Offset(, 2 + (J * 3)).Resize(, 3).Copy wsNew.Range("A" & I).Offset(J, 3)
        Next J
        I = I + 3
        Set rng = rng.Offset(1)
    Wend
End Sub

 

[mbogan]

That work perfectly. Now the only problem is that I have more than 3 sets of Codes across.

I think there are 24, however, I am not sure. There may be more or less when I get the data feed. How can we modify it to keep looking for codes to the right until it finds a blank field, then it should move on to the next row.

Thank you so much for your help!!

 

[Norie]

I think the code would have to be changed quite a bit to work with that.

Can you post some more example data, with more than 3 groups of codes?

 

[mbogan]

I can do it manually. I just took a sample that had 24 sets of 3 codes. So the header range was from A1:BV1

Here is what I adjusted in the code to make it work:

Sub test()
Dim wsData As Worksheet
Dim wsNew As Worksheet
Dim rng As Range
Dim I As Long
Dim J As Long
Dim arrHeadings

    arrHeadings = Array("Company Name", "Name", "Description", "Code1", "Code2", "Code3")

    Set wsData = ActiveSheet
    Set wsNew = Worksheets.Add

    wsNew.Range("A1:F1") = arrHeadings
    I = 2
    
    Set rng = wsData.Range("A2")
    
    While rng.Value <> ""
        
        rng.Resize(, 2).Copy wsNew.Range("A" & I).Resize(24, 2)
        For J = 0 To 23
            wsNew.Range("A" & I).Offset(J, 2) = Left(wsData.Cells(1, rng.Offset(, 2 + (J * 3)).Column), 3)
            rng.Offset(, 2 + (J * 3)).Resize(, 3).Copy wsNew.Range("A" & I).Offset(J, 3)
        Next J
        I = I + 24
        Set rng = rng.Offset(1)
    Wend
End Sub

It looks like it did the trick. So, I can adjust it accordinly, which will work fine