macro to modify report

[skalaima]

Hello,

I'm trying to write a macro that modifies the layout of my report, but I'm at a loss for figuring out the algorithmn . I would really appreciate some help. (sorry for the long description, see example below for a visual)

In column A there are headers, in column B there are sub-headers, in column C there are questions and in column D there are answers. The current layout has headers/sub-headers/questions/answers in every row. I've sorted the data by headers (column A) then by sub-headers (col B).
I'd like the report to have the following layout: Each unique header to have it's own row (merged across columns A to D), the row below that to have the sub-header merged (columns A to D) and the row(s) below that to have the question(s) in column A and the answer(s) adjacent to it in column B.
For each header there are 2-5 sub-headers and for each sub-header there are a variable amount of questions and answers.

Example - sample of current report (H - header, SH - subheader, Q - question, A - answer):
row1 - H1 (colA), SH1(colB), Q1 (colC), A1 (colD)
row2 - H1, SH1, Q2, A2
row3 - H1, SH2, Q3, A3
row4 - H2, SH3, Q4, A4

Preferred layout:
row1 - H1 (colA to colD)
row2 - SH1 (colA to colD)
row3 - Q1 (colA), A1 (colB)
row4 - Q2 (colA), A2 (colB)
row5 - SH2 (colA to colD)
row6 - Q3 (colA), A3 (colB)
row7 - H2 (colA to colD)
row8 - SH3 (colA to colD)
row9 - Q4 (colA), A4 (colB)

 

[Comfy]

Option Explicit
Sub Amend_Layout()
    Dim Data As Range, r As Range, Output As Range
        
    Set Data = Selection
    Set Output = Application.InputBox("Select the Output Start", "Output", Type:=8)
    For Each r In Data.Rows
        If Not r.Value2(1, 1) = Cells(r.Row - 1, r.Column).Value Then
            Range(Cells(Output.Row, Output.Column), Cells(Output.Row, Output.Column + 3)).Cells.Merge
            Range(Cells(Output.Row, Output.Column), Cells(Output.Row, Output.Column + 3)).Value = r.Value2(1, 1)
            Set Output = Output.Offset(1, 0)
            Range(Cells(Output.Row, Output.Column), Cells(Output.Row, Output.Column + 3)).Cells.Merge
            Range(Cells(Output.Row, Output.Column), Cells(Output.Row, Output.Column + 3)).Value = r.Value2(1, 2)
            Set Output = Output.Offset(1, 0)
            Cells(Output.Row, Output.Column).Value = r.Value2(1, 3)
            Cells(Output.Row, Output.Column + 1).Value = r.Value2(1, 4)
            Set Output = Output.Offset(1, 0)
        Else
            If Not r.Value2(1, 2) = Cells(r.Row - 1, r.Column + 1).Value Then
                Range(Cells(Output.Row, Output.Column), Cells(Output.Row, Output.Column + 3)).Cells.Merge
                Range(Cells(Output.Row, Output.Column), Cells(Output.Row, Output.Column + 3)).Value = r.Value2(1, 2)
                Set Output = Output.Offset(1, 0)
            Else
                Cells(Output.Row, Output.Column).Value = r.Value2(1, 3)
                Cells(Output.Row, Output.Column + 1).Value = r.Value2(1, 4)
                Set Output = Output.Offset(1, 0)
            End If
        End If
    Next
End Sub

Finishing work now so can't finish so pasted what I can.

You need to select the range that needs to be transpose first before running, this can be changed.

There is no error checking for the output range selection, this too can be changed.

/Comfy

 

[Comfy]

Slight amendment as I had missed the transposing of Q & A when H matches previous but SH doesn't.

Option Explicit
Sub Amend_Layout()
    Dim Data As Range, r As Range, Output As Range
        
    Set Data = Selection
    Set Output = Application.InputBox("Select the Output Start", "Output", Type:=8)
    For Each r In Data.Rows
        If Not r.Value2(1, 1) = Cells(r.Row - 1, r.Column).Value Then
            Range(Cells(Output.Row, Output.Column), Cells(Output.Row, Output.Column + 3)).Cells.Merge
            Range(Cells(Output.Row, Output.Column), Cells(Output.Row, Output.Column + 3)).Value = r.Value2(1, 1)
            Set Output = Output.Offset(1, 0)
            Range(Cells(Output.Row, Output.Column), Cells(Output.Row, Output.Column + 3)).Cells.Merge
            Range(Cells(Output.Row, Output.Column), Cells(Output.Row, Output.Column + 3)).Value = r.Value2(1, 2)
            Set Output = Output.Offset(1, 0)
            Cells(Output.Row, Output.Column).Value = r.Value2(1, 3)
            Cells(Output.Row, Output.Column + 1).Value = r.Value2(1, 4)
            Set Output = Output.Offset(1, 0)
        Else
            If Not r.Value2(1, 2) = Cells(r.Row - 1, r.Column + 1).Value Then
                Range(Cells(Output.Row, Output.Column), Cells(Output.Row, Output.Column + 3)).Cells.Merge
                Range(Cells(Output.Row, Output.Column), Cells(Output.Row, Output.Column + 3)).Value = r.Value2(1, 2)
                Set Output = Output.Offset(1, 0)
                Cells(Output.Row, Output.Column).Value = r.Value2(1, 3)
                Cells(Output.Row, Output.Column + 1).Value = r.Value2(1, 4)
                Set Output = Output.Offset(1, 0)
            Else
                Cells(Output.Row, Output.Column).Value = r.Value2(1, 3)
                Cells(Output.Row, Output.Column + 1).Value = r.Value2(1, 4)
                Set Output = Output.Offset(1, 0)
            End If
        End If
    Next
End Sub

 

[MickG]

Try this:-
Results start "F1"

[COLOR="Navy"]Sub[/COLOR] MG11May31
[COLOR="Navy"]Dim[/COLOR] Rng [COLOR="Navy"]As[/COLOR] Range, Dn [COLOR="Navy"]As[/COLOR] Range
[COLOR="Navy"]Dim[/COLOR] Q [COLOR="Navy"]As[/COLOR] Variant
[COLOR="Navy"]Dim[/COLOR] K  [COLOR="Navy"]As[/COLOR] Variant
[COLOR="Navy"]Dim[/COLOR] p [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Integer[/COLOR]
[COLOR="Navy"]Dim[/COLOR] c [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long[/COLOR]
[COLOR="Navy"]Set[/COLOR] Rng = Range(Range("A1"), Range("A" & rows.Count).End(xlUp))
ReDim ray(1 To Rng.Count * 4, 1 To 2)
[COLOR="Navy"]With[/COLOR] CreateObject("scripting.dictionary")
.CompareMode = vbTextCompare
[COLOR="Navy"]For[/COLOR] [COLOR="Navy"]Each[/COLOR] Dn [COLOR="Navy"]In[/COLOR] Rng
    [COLOR="Navy"]If[/COLOR] Not .Exists(Dn.value) [COLOR="Navy"]Then[/COLOR]
        ray(1, 1) = Dn: ray(2, 1) = Dn(, 2): ray(3, 1) = Dn(, 3): ray(3, 2) = Dn(, 4)
        .Add Dn.value, Array(ray, 3, Dn)
    [COLOR="Navy"]Else[/COLOR]
        Q = .Item(Dn.value)
        [COLOR="Navy"]If[/COLOR] Dn(, 2) = Q(2).Offset(, 1) [COLOR="Navy"]Then[/COLOR]
            Q(1) = Q(1) + 1
            Q(0)(Q(1), 1) = Dn(, 3): Q(0)(Q(1), 2) = Dn(, 4)
        [COLOR="Navy"]Else[/COLOR]
            Q(1) = Q(1) + 1
            Q(0)(Q(1), 1) = Dn(, 2)
            Q(1) = Q(1) + 1
            Q(0)(Q(1), 1) = Dn(, 3): Q(0)(Q(1), 2) = Dn(, 4)
        [COLOR="Navy"]End[/COLOR] If
        .Item(Dn.value) = Q
[COLOR="Navy"]End[/COLOR] If
[COLOR="Navy"]Next[/COLOR]
[COLOR="Navy"]For[/COLOR] [COLOR="Navy"]Each[/COLOR] K [COLOR="Navy"]In[/COLOR] .keys
    [COLOR="Navy"]For[/COLOR] p = 1 To .Item(K)(1)
        c = c + 1
        Cells(c, "F") = .Item(K)(0)(p, 1)
        Cells(c, "G") = .Item(K)(0)(p, 2)
    [COLOR="Navy"]Next[/COLOR] p
[COLOR="Navy"]Next[/COLOR] K
[COLOR="Navy"]End[/COLOR] [COLOR="Navy"]With[/COLOR]
[COLOR="Navy"]End[/COLOR] [COLOR="Navy"]Sub[/COLOR]

Regards Mick

 

[skalaima]

Thank you both for your help! I was able to get the macro to work using some of the logic from both your posts.

I ran in to a lot of errors along the way, but I found it very useful to utilize a second worksheet. That way instead of re-arranging data within the current sheet, I moved the data over to a new sheet during the loops. The offset feature helped a ton!