VBA to Paste heading based on how many subheadings there are?

[SleightOfHand]

Hello,

I've got a question to the forum who have been ever so helpful whenever I've had a request.

I have a table that looks sort of like this:

Copy of Copy of Future States Input Template_v1.3.xlsm
	D	E	F
5	Project identification
6
7	Project name	a
8	Project code	b
9	Associated projects (list codes)	c
10
11	Principal Funder	Select one only
12
13	X		(y/n)
14	Y		(y/n)
15	Z		(y/n)
16	XN		(y/n)
17	YN		(y/n)
v2

You can see that under 'project identification' it has three headings; project name code and associated projects.

The next under funder has five sections.

While it is fine to create a macro to copy and paste general data (e.g. in the yellow cells), would there be an easy way to hardpaste those underlined headings into one merged/centred across cell dependant on how many subheadings there are. Sometimes these will be editted etc.

So, something like this

Copy of Copy of Future States Input Template_v1.3.xlsm
	A	B	C	D	E	F	G	H
1	Project identification			Principal Funder
2	Project name	Project code	Associated projects (list codes)	X	Y	Z	XN	YN
Log

Right now I can just copy and paste them into an individual cell each.

Cheers!

 

[mumps]

Try this macro. The new data will be placed in Sheet2. Change the sheet names (in red) to suit your needs.

Sub TransposeData()
    Application.ScreenUpdating = False
    Dim LastRow As Long, srcWS As Worksheet, desWS As Worksheet
    Dim fnd1 As Long, fnd2 As Long, FR As Long, cnt As Long, FR2 As Long, cnt2 As Long
    Set srcWS = Sheets("Sheet1")
    Set desWS = Sheets("Sheet2")
    LastRow = srcWS.Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
    fnd1 = Range("D:D").Find("Project identification", LookIn:=xlValues, lookat:=xlWhole).Row
    fnd2 = Range("D:D").Find("Principal Funder", LookIn:=xlValues, lookat:=xlWhole).Row
    With srcWS.Range("D" & fnd1 + 2 & ":D" & LastRow).SpecialCells(xlCellTypeConstants).Areas
        FR = .Item(1).Row
        cnt = .Item(1).Cells.Count
    End With
    With srcWS.Range("D" & fnd2 + 2 & ":D" & LastRow).SpecialCells(xlCellTypeConstants).Areas
        FR2 = .Item(1).Row
        cnt2 = .Item(1).Cells.Count
    End With
    With desWS
        With .Range("A1")
            .Value = "Project identification"
            .Resize(, cnt).HorizontalAlignment = xlCenterAcrossSelection
        End With
        .Cells(.Rows.Count, "A").End(xlUp).Offset(1).Resize(, cnt).Value = Application.Transpose(Range("D" & fnd1 + 2).Resize(cnt))
        With .Cells(1, cnt + 1)
            .Value = "Principal Funder"
            .Resize(, cnt2).HorizontalAlignment = xlCenterAcrossSelection
        End With
        .Cells(.Rows.Count, cnt + 1).End(xlUp).Offset(1).Resize(, cnt2).Value = Application.Transpose(Range("D" & fnd2 + 2).Resize(cnt2))
        .Columns.AutoFit
    End With
    Application.ScreenUpdating = True
End Sub

Please note that the macro does not merge any cells. It uses "xlCenterAcrossSelection" which achieves the same visual effect as merging. Excel macros and merged cells don't "get along" with each other most times.

 

[SleightOfHand]

Try this macro. The new data will be placed in Sheet2. Change the sheet names (in red) to suit your needs.

Sub TransposeData()
    Application.ScreenUpdating = False
    Dim LastRow As Long, srcWS As Worksheet, desWS As Worksheet
    Dim fnd1 As Long, fnd2 As Long, FR As Long, cnt As Long, FR2 As Long, cnt2 As Long
    Set srcWS = Sheets("Sheet1")
    Set desWS = Sheets("Sheet2")
    LastRow = srcWS.Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
    fnd1 = Range("D:D").Find("Project identification", LookIn:=xlValues, lookat:=xlWhole).Row
    fnd2 = Range("D:D").Find("Principal Funder", LookIn:=xlValues, lookat:=xlWhole).Row
    With srcWS.Range("D" & fnd1 + 2 & ":D" & LastRow).SpecialCells(xlCellTypeConstants).Areas
        FR = .Item(1).Row
        cnt = .Item(1).Cells.Count
    End With
    With srcWS.Range("D" & fnd2 + 2 & ":D" & LastRow).SpecialCells(xlCellTypeConstants).Areas
        FR2 = .Item(1).Row
        cnt2 = .Item(1).Cells.Count
    End With
    With desWS
        With .Range("A1")
            .Value = "Project identification"
            .Resize(, cnt).HorizontalAlignment = xlCenterAcrossSelection
        End With
        .Cells(.Rows.Count, "A").End(xlUp).Offset(1).Resize(, cnt).Value = Application.Transpose(Range("D" & fnd1 + 2).Resize(cnt))
        With .Cells(1, cnt + 1)
            .Value = "Principal Funder"
            .Resize(, cnt2).HorizontalAlignment = xlCenterAcrossSelection
        End With
        .Cells(.Rows.Count, cnt + 1).End(xlUp).Offset(1).Resize(, cnt2).Value = Application.Transpose(Range("D" & fnd2 + 2).Resize(cnt2))
        .Columns.AutoFit
    End With
    Application.ScreenUpdating = True
End Sub

Please note that the macro does not merge any cells. It uses "xlCenterAcrossSelection" which achieves the same visual effect as merging. Excel macros and merged cells don't "get along" with each other most times.

This is excellent, thank you so much. The fact that you took the time to make this is so good of ya. Cheers!

 

[mumps]

You are very welcome.