Macro copy first value from multiple header rows to new sheet based on header

[clazzic]

Hi, ive got a complication with pulling certain data based on header columns, my Data sample set looks like below.

header1	header2	header3	header4
1	6	5	6
2	5	54	5
3	23	56	54
4	4	54	6
header1	header4	header 3	header2	header5	header6
5	2	3	2	12	2
2	54	2	12	2	5
3	5	3	2	1	4
header1	header2	header 3
2	5	5
3	5	4
5	6	5
4	5	5

<colgroup><col width="64" span="8" style="width:48pt"> </colgroup><tbody>
</tbody>

The first Header row in the sourcesheet "Sheet1" will be in the 3rd row and there will be 100s of data sets that varies in length but will be seperated by a blank row.

The targetsheet "Sheet2" will have the the headers that i want data for, it will be matching with the headers in sourceshseet. e.g. header1,header2,header3

What i need is for it to loop through each header row for each data set in sourcesheet, and pull the first value of that data set to the targetsheet under the Target header row (row 1)

desired outcome:

header1	header2	header3
1	6	5
5	2	3
2	5	5

<colgroup><col width="64" span="3" style="width:48pt"> </colgroup><tbody>
</tbody>

Thanks guys,

 

[MickG]

Try this for results on sheet2.

[COLOR="Navy"]Sub[/COLOR] MG01Aug27
[COLOR="Navy"]Dim[/COLOR] Rng [COLOR="Navy"]As[/COLOR] Range, Dn [COLOR="Navy"]As[/COLOR] Range, Ac [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long,[/COLOR] c [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long,[/COLOR] Ray()
Set Rng = Range("A:A").SpecialCells(xlCellTypeConstants) '[COLOR="Green"][B][/B][/COLOR]
c = 1
[COLOR="Navy"]For[/COLOR] [COLOR="Navy"]Each[/COLOR] Dn [COLOR="Navy"]In[/COLOR] Rng.Areas
    c = c + 1
    ReDim Preserve Ray(1 To 3, 1 To c)
    [COLOR="Navy"]For[/COLOR] Ac = 1 To 3
        [COLOR="Navy"]If[/COLOR] c = 2 [COLOR="Navy"]Then[/COLOR] Ray(Ac, 1) = Dn(1).Offset(, Ac - 1).Value
        Ray(Ac, UBound(Ray, 2)) = Dn(2).Offset(, Ac - 1).Value
    [COLOR="Navy"]Next[/COLOR] Ac
[COLOR="Navy"]Next[/COLOR] Dn
[COLOR="Navy"]With[/COLOR] Sheets("Sheet2").Range("A1").Resize(UBound(Ray, 2), 3)
  .Value = Application.Transpose(Ray)
  .Columns.AutoFit
  .Borders.Weight = 2
[COLOR="Navy"]End[/COLOR] [COLOR="Navy"]With[/COLOR]
[COLOR="Navy"]End[/COLOR] [COLOR="Navy"]Sub[/COLOR]

Regards Mick

 

[clazzic]

Try this for results on sheet2.

[COLOR=Navy]Sub[/COLOR] MG01Aug27
[COLOR=Navy]Dim[/COLOR] Rng [COLOR=Navy]As[/COLOR] Range, Dn [COLOR=Navy]As[/COLOR] Range, Ac [COLOR=Navy]As[/COLOR] [COLOR=Navy]Long,[/COLOR] c [COLOR=Navy]As[/COLOR] [COLOR=Navy]Long,[/COLOR] Ray()
Set Rng = Range("A:A").SpecialCells(xlCellTypeConstants) '
c = 1
[COLOR=Navy]For[/COLOR] [COLOR=Navy]Each[/COLOR] Dn [COLOR=Navy]In[/COLOR] Rng.Areas
    c = c + 1
    ReDim Preserve Ray(1 To 3, 1 To c)
    [COLOR=Navy]For[/COLOR] Ac = 1 To 3
        [COLOR=Navy]If[/COLOR] c = 2 [COLOR=Navy]Then[/COLOR] Ray(Ac, 1) = Dn(1).Offset(, Ac - 1).Value
        Ray(Ac, UBound(Ray, 2)) = Dn(2).Offset(, Ac - 1).Value
    [COLOR=Navy]Next[/COLOR] Ac
[COLOR=Navy]Next[/COLOR] Dn
[COLOR=Navy]With[/COLOR] Sheets("Sheet2").Range("A1").Resize(UBound(Ray, 2), 3)
  .Value = Application.Transpose(Ray)
  .Columns.AutoFit
  .Borders.Weight = 2
[COLOR=Navy]End[/COLOR] [COLOR=Navy]With[/COLOR]
[COLOR=Navy]End[/COLOR] [COLOR=Navy]Sub[/COLOR]

Regards Mick

Thanks for the quick response Mick,

the code didnt return any of the values under the data set headers in sheet 1,
it only resizes and add borders. which part of the code reference the data set headers in the sourcesheet(sheet1)?

 

[MickG]

Try the example below, Should do what you want.
https://app.box.com/s/tzoegcp69vzc54o9j7b8e9i7xgvn1kgf

Regrds Mick

 

[clazzic]

thank Mick it work,

the function's there, but it keeps replacing the headers title that i put in Sheet 2, with the first few in sheet 1.

my actual data has approx 40 column header, and the one i want are only 3 (for now) position in different columns.

regards
Tony

 

[MickG]

If you want to remove the headers in the results, Remove the line in Red.
The results will still show the first 3 columns in each Area.
If you want to replace the headers or number of columns in the results, you will need to specify some sort of criteria.

 [COLOR=navy]For[/COLOR] Ac = 1 To 3
        [B][COLOR=#FF0000]If c = 2 Then Ray(Ac, 1) = Dn(1).Offset(, Ac - 1).Value[/COLOR][/B]
        Ray(Ac, UBound(Ray, 2)) = Dn(2).Offset(, Ac - 1).Value
    [COLOR=navy]Next[/COLOR] Ac

 

[clazzic]

yeah i realised that it only pulls the values in the first 3 columns,

if the my scenario is that the columns values i need are in columns e.g. col10, col 15, col30,

how would i get the values under all the source headers for each data set (sheet1) that matches the target headers (sheet2)?

 

[MickG]

Perhaps this:-

[COLOR="Navy"]Sub[/COLOR] MG02Aug51
[COLOR="Navy"]Dim[/COLOR] Rng [COLOR="Navy"]As[/COLOR] Range, Dn [COLOR="Navy"]As[/COLOR] Range, Ac [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long,[/COLOR] c [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long,[/COLOR] Ray(), col [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long[/COLOR]
Set Rng = Range("J:J").SpecialCells(xlCellTypeConstants) '[COLOR="Green"][B][/B][/COLOR]
c = 1
[COLOR="Navy"]For[/COLOR] [COLOR="Navy"]Each[/COLOR] Dn [COLOR="Navy"]In[/COLOR] Rng.Areas
    c = c + 1
    ReDim Preserve Ray(1 To 3, 1 To c)
    [COLOR="Navy"]For[/COLOR] Ac = 1 To 3
        [COLOR="Navy"]Select[/COLOR] [COLOR="Navy"]Case[/COLOR] Ac
            [COLOR="Navy"]Case[/COLOR] 1: col = 0
            [COLOR="Navy"]Case[/COLOR] 2: col = 5
            [COLOR="Navy"]Case[/COLOR] 3: col = 20
        [COLOR="Navy"]End[/COLOR] Select
        If c = 2 Then Ray(Ac, 1) = Dn(1).Offset(, col).Value '[COLOR="Green"][B]remove this line if Headers not required !!![/B][/COLOR]
        Ray(Ac, UBound(Ray, 2)) = Dn(2).Offset(, col).Value
       
    [COLOR="Navy"]Next[/COLOR] Ac
[COLOR="Navy"]Next[/COLOR] Dn
[COLOR="Navy"]With[/COLOR] Sheets("Sheet2").Range("A1").Resize(UBound(Ray, 2), 3)
  .Value = Application.Transpose(Ray)
  .Columns.AutoFit
  .Borders.Weight = 2
[COLOR="Navy"]End[/COLOR] With
[COLOR="Navy"]End[/COLOR] [COLOR="Navy"]Sub[/COLOR]

Regards Mick