VBA Reorganise excel Table

B

BKChedlia

New Member
Joined
Jun 15, 2016
Messages
41
HI,
I have a table with 4 columns : "questionID", "Question", "Response", "clientName"
for the same question, we have alot of responses from differents clients, I would like some ideas to clean up my data in new sheet and don't display multiple rows for the same questionId.
this what I have
questionIDQuestionResponseclientName
111Q01responseq011clientA
111Q01responseq012clientB
222Q02responseq021clientA
222Q02responseq022clientB

<tbody>
</tbody>

this is what I need

questionID111222
questionQ01Q02
responseresponseq011responseq021clientA
responseq012responseq022clientB

<tbody>
</tbody>

Any ideas to begin my VBA code? thanks
 
Last edited:

Excel Facts

Last used cell?
Press Ctrl+End to move to what Excel thinks is the last used cell.
Sort by date Sort by votes
M

MickG

MrExcel MVP
Joined
Jan 9, 2008
Messages
14,841
Try this:-
For results starting "G1".
It works on the data you posted but , I'm unsure if it will work for more complicated data.
It you find problems please post more comprehensive data.
Code: 
[COLOR=navy]Sub[/COLOR] MG02Dec56
[COLOR=navy]Dim[/COLOR] Rng [COLOR=navy]As[/COLOR] Range, Dn [COLOR=navy]As[/COLOR] Range, n [COLOR=navy]As[/COLOR] [COLOR=navy]Long,[/COLOR] num [COLOR=navy]As[/COLOR] [COLOR=navy]Long,[/COLOR] q
[COLOR=navy]Set[/COLOR] Rng = Range(Range("A1"), Range("A" & Rows.Count).End(xlUp))
[COLOR=navy]Dim[/COLOR] Dic [COLOR=navy]As[/COLOR] Object, Rw [COLOR=navy]As[/COLOR] [COLOR=navy]Long[/COLOR]
Rw = 2
[COLOR=navy]Set[/COLOR] Dic = CreateObject("scripting.dictionary")
Dic.CompareMode = vbTextCompare
[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]
    .Add Dn.Value, Dn
[COLOR=navy]Else[/COLOR]
    [COLOR=navy]Set[/COLOR] .Item(Dn.Value) = Union(.Item(Dn.Value), Dn)
[COLOR=navy]End[/COLOR] If
[COLOR=navy]Next[/COLOR]
[COLOR=navy]Dim[/COLOR] K [COLOR=navy]As[/COLOR] Variant, p [COLOR=navy]As[/COLOR] Variant, ac [COLOR=navy]As[/COLOR] [COLOR=navy]Long,[/COLOR] c [COLOR=navy]As[/COLOR] [COLOR=navy]Long[/COLOR]
ReDim ray(1 To Rng.Count, 1 To 1)
[COLOR=navy]For[/COLOR] [COLOR=navy]Each[/COLOR] K [COLOR=navy]In[/COLOR] .keys
    ac = ac + 1
     [COLOR=navy]If[/COLOR] UBound(ray, 2) < ac [COLOR=navy]Then[/COLOR] ReDim Preserve ray(1 To Rng.Count, 1 To ac)
        ray(1, ac) = K
        ray(2, ac) = .Item(K)(1).Offset(, 1).Value
        ray(3, 1) = "Response"
[COLOR=navy]Next[/COLOR] K

ReDim Preserve ray(1 To Rng.Count, 1 To UBound(ray, 2) + 1)
[COLOR=navy]For[/COLOR] [COLOR=navy]Each[/COLOR] Dn [COLOR=navy]In[/COLOR] Rng.Offset(, 3)
    [COLOR=navy]If[/COLOR] Not Dic.exists(Dn.Value) And Not Dn.Row = 1 [COLOR=navy]Then[/COLOR]
        Dic(Dn.Value) = Empty
        Rw = Rw + 1
        ray(Rw, UBound(ray, 2)) = Dn.Value
    [COLOR=navy]End[/COLOR] If
[COLOR=navy]Next[/COLOR]
[COLOR=navy]For[/COLOR] ac = 2 To UBound(ray, 2) - 1
    [COLOR=navy]For[/COLOR] n = 3 To UBound(ray, 1)
        [COLOR=navy]For[/COLOR] [COLOR=navy]Each[/COLOR] p [COLOR=navy]In[/COLOR] .Item(ray(1, ac))
            [COLOR=navy]If[/COLOR] ray(n, UBound(ray, 2)) = p.Offset(, 3).Value [COLOR=navy]Then[/COLOR]
                ray(n, ac) = p.Offset(, 2).Value
            [COLOR=navy]End[/COLOR] If
        [COLOR=navy]Next[/COLOR] p
    [COLOR=navy]Next[/COLOR] n
[COLOR=navy]Next[/COLOR] ac
[COLOR=navy]End[/COLOR] With
Range("G1").Resize(Rw, UBound(ray, 2)) = ray
[COLOR=navy]End[/COLOR] [COLOR=navy]Sub[/COLOR]
Regards Mick
 
Last edited:
Upvote 0
B

BKChedlia

New Member
Joined
Jun 15, 2016
Messages
41
Dear Mark,
Thank you for this code, it works for my sample, I will try it on a huge number of questions.
Instead of G1 cell, is there a way to put it in new sheet ?
 
Upvote 0
M

MickG

MrExcel MVP
Joined
Jan 9, 2008
Messages
14,841
Your welcome
Try altering last line to similar to below:-
Code: 
Sheets("Shee2").Range("A1").Resize(Rw, UBound(ray, 2)) = ray
 
Upvote 0
B

BKChedlia

New Member
Joined
Jun 15, 2016
Messages
41
ADVERTISEMENT
Thankx alot, I am very happy that it works, and I will follow your code to understand how it works.
 
Upvote 0
Ombir

Ombir

Active Member
Joined
Oct 1, 2015
Messages
433
ADVERTISEMENT
Hi Bk,

I also tried to solve this complicated problem using alternative approach. Its working fine on your sample data.

Can you check my code on your real data if its working correctly or not. If not, then can post some additional data so that I can test it ?

Code: 
Sub rotate()
Dim i       As Long
Dim j       As Long
Dim n       As Long
Dim rw      As String
Dim x       As String
Dim cell    As Range
Dim rng     As Range
Dim k       As Variant
Dim ky      As Variant
Dim dic     As Object
Dim dc      As Object
Dim ws      As Worksheet

Set ws = Sheets("Sheet2")
Set dic = CreateObject("scripting.dictionary")
Set dc = CreateObject("scripting.dictionary")
Set rng = Sheet1.Range("A2:A" & Cells(Rows.Count, 1).End(xlUp).Row)

i = 2
For Each cell In Range("D2:D" & Cells(Rows.Count, 1).End(xlUp).Row)
    If Not dc.exists(cell.Value) Then
            i = i + 1
            dc.Add cell.Value, i
    End If
Next

With dic

For Each cell In rng
    If Not .exists(cell.Value) Then
        Set dic(cell.Value) = CreateObject("scripting.dictionary")
        dic(cell.Value).Item(cell.Offset(, 1).Value) = cell.Offset(, 2) & "~" & cell.Offset(, 3)
    Else
        If Not dic(cell.Value).exists(cell.Offset(, 1).Value) Then
            dic(cell.Value).Add cell.Offset(, 1).Value, cell.Offset(, 2) & "~" & cell.Offset(, 3)
        Else
            x = cell.Offset(, 2) & "~" & cell.Offset(, 3)
            dic(cell.Value).Item(cell.Offset(, 1).Value) = dic(cell.Value).Item(cell.Offset(, 1).Value) & ";" & x
        End If
    End If
Next

j = 1

For Each k In .keys
  n = 0
    For Each ky In dic(k).keys
    ws.Cells(1, j) = k
        ws.Cells(2, j) = ky
        For n = 0 To UBound(Split(dic(k).Item(ky), ";"))
            que = Split(dic(k).Item(ky), ";")(n)
            client = Split(que, "~")(1)
            rw = dc.Item(client)
            ws.Cells(rw, j) = Split(que, "~")(0)
        Next
        j = j + 1
    Next
Next
ws.Cells(3, j).Resize(dc.Count) = Application.Transpose(dc.keys())
End With
Set dic = Nothing
Set dc = Nothing
End Sub
 
Upvote 0
B

BKChedlia

New Member
Joined
Jun 15, 2016
Messages
41
Thanks for your code I tried it but I have type mismatch for this line :

ws.Cells(rw, j) = Split(que, "~")(0)
could you comment your code to understand it
help plz
 
Upvote 0
Ombir

Ombir

Active Member
Joined
Oct 1, 2015
Messages
433
Can you share the data on which you're testing(If its confidential then you can share it in dummy form). I need to check why you're getting this error. Once I'll figure out the problem then I will post the revised code with comments.
 
Upvote 0
B

BKChedlia

New Member
Joined
Jun 15, 2016
Messages
41
Code: 
[TABLE="width: 781"]
<tbody>[TR]
[TD]questionID[/TD]
[TD]Question[/TD]
[TD]Response[/TD]
[TD]clientName[/TD]
[/TR]
[TR]
[TD="align: right"]5[/TD]
[TD]Email address of the engagement Manager[/TD]
[TD]updu[/TD]
[TD]T - Audits[/TD]
[/TR]
[TR]
[TD="align: right"]5[/TD]
[TD]Email address of the engagement Manager[/TD]
[TD][/TD]
[TD]T - P Cyprus[/TD]
[/TR]
[TR]
[TD="align: right"]5[/TD]
[TD]Email address of the engagement Manager[/TD]
[TD][/TD]
[TD]T - P UK[/TD]
[/TR]
[TR]
[TD="align: right"]5[/TD]
[TD]Email address of the engagement Manager[/TD]
[TD][/TD]
[TD]T - PIndia[/TD]
[/TR]
[TR]
[TD="align: right"]5[/TD]
[TD]Email address of the engagement Manager[/TD]
[TD][/TD]
[TD]T - P France[/TD]
[/TR]
[TR]
[TD="align: right"]5[/TD]
[TD]Email address of the engagement Manager[/TD]
[TD][/TD]
[TD]T - P Belgium[/TD]
[/TR]
[TR]
[TD="align: right"]6[/TD]
[TD]Email address of the engagement partner[/TD]
[TD]ddd[/TD]
[TD]T - Audits[/TD]
[/TR]
[TR]
[TD="align: right"]6[/TD]
[TD]Email address of the engagement partner[/TD]
[TD]ddd[/TD]
[TD]T - P Cyprus[/TD]
[/TR]
[TR]
[TD="align: right"]6[/TD]
[TD]Email address of the engagement partner[/TD]
[TD]kjà[/TD]
[TD]T - P UK[/TD]
[/TR]
[TR]
[TD="align: right"]6[/TD]
[TD]Email address of the engagement partner[/TD]
[TD]kjà[/TD]
[TD]T - P India[/TD]
[/TR]
[TR]
[TD="align: right"]6[/TD]
[TD]Email address of the engagement partner[/TD]
[TD]leroux[/TD]
[TD]T - P France[/TD]
[/TR]
[TR]
[TD="align: right"]6[/TD]
[TD]Email address of the engagement partner[/TD]
[TD]mmm[/TD]
[TD]T - P Belgium[/TD]
[/TR]
[TR]
[TD="align: right"]7[/TD]
[TD]Number of entities subject to a statutory audit[/TD]
[TD="align: right"]1432[/TD]
[TD]T - Audits[/TD]
[/TR]
[TR]
[TD="align: right"]7[/TD]
[TD]Number of entities subject to a statutory audit[/TD]
[TD="align: right"]1433[/TD]
[TD]T - P Cyprus[/TD]
[/TR]
[TR]
[TD="align: right"]7[/TD]
[TD]Number of entities subject to a statutory audit[/TD]
[TD="align: right"]1432[/TD]
[TD]T - P UK[/TD]
[/TR]
[TR]
[TD="align: right"]7[/TD]
[TD]Number of entities subject to a statutory audit[/TD]
[TD="align: right"]1432[/TD]
[TD]T - P India[/TD]
[/TR]
[TR]
[TD="align: right"]7[/TD]
[TD]Number of entities subject to a statutory audit[/TD]
[TD="align: right"]1435[/TD]
[TD]T - P France[/TD]
[/TR]
[TR]
[TD="align: right"]7[/TD]
[TD]Number of entities subject to a statutory audit[/TD]
[TD="align: right"]1433[/TD]
[TD]T - P Belgium[/TD]
[/TR]
[TR]
[TD="align: right"]11[/TD]
[TD]Entity name[/TD]
[TD]jdlksa[/TD]
[TD]T - Audits[/TD]
[/TR]
[TR]
[TD="align: right"]11[/TD]
[TD]Entity name[/TD]
[TD]dfsjé[/TD]
[TD]T - P Belgium[/TD]
[/TR]
[TR]
[TD="align: right"]11[/TD]
[TD]Entity name[/TD]
[TD]sfsdf[/TD]
[TD]T - P Cyprus[/TD]
[/TR]
[TR]
[TD="align: right"]11[/TD]
[TD]Entity name[/TD]
[TD]dfsdf[/TD]
[TD]T - P UK[/TD]
[/TR]
[TR]
[TD="align: right"]11[/TD]
[TD]Entity name[/TD]
[TD]sdfds[/TD]
[TD]T - P India[/TD]
[/TR]
[TR]
[TD="align: right"]11[/TD]
[TD]Entity name[/TD]
[TD]Viveo France[/TD]
[TD]T - P France[/TD]
[/TR]
[TR]
[TD="align: right"]12[/TD]
[TD]Local client contact name[/TD]
[TD]djlkdjas[/TD]
[TD]T - Audits[/TD]
[/TR]
[TR]
[TD="align: right"]12[/TD]
[TD]Local client contact name[/TD]
[TD]romeo[/TD]
[TD]T - P Belgium[/TD]
[/TR]
[TR]
[TD="align: right"]12[/TD]
[TD]Local client contact name[/TD]
[TD]mary[/TD]
[TD]T - P Cyprus[/TD]
[/TR]
[TR]
[TD="align: right"]12[/TD]
[TD]Local client contact name[/TD]
[TD]dfd[/TD]
[TD]T - P UK[/TD]
[/TR]
[TR]
[TD="align: right"]12[/TD]
[TD]Local client contact name[/TD]
[TD]jean[/TD]
[TD]T - P France[/TD]
[/TR]
[TR]
[TD="align: right"]12[/TD]
[TD]Local client contact name[/TD]
[TD]mr vvv[/TD]
[TD]T - P India[/TD]
[/TR]
[TR]
[TD="align: right"][/TD]
[TD][/TD]
[TD="align: right"][/TD]
[TD][/TD]
[/TR]
</tbody>[/TABLE]
 
Last edited:
Upvote 0
You must log in or register to reply here.

Similar threads

J
  • Solved
Excel VBA - Loop Through Empty Cells and Get Value From Another
Replies
3
Views
3K
Joe4
Joe4
D
  • Question
Showing values in a pivot table as a percentage of value in another pivot table
Replies
0
Views
585
dropjinx
D
J
  • Solved
Fill a filtered column in a table with a text value "Y"
Replies
2
Views
270
johnlink
J
F
  • Question
VBA pulling data from a dataset to generate many templates pre-filled
Replies
1
Views
522
Fiddling4033
F
S
  • Question
Consolidate and transpose table (using VBA)
Replies
1
Views
789
DanteAmor
DanteAmor

Forum statistics

Threads
1,196,021
Messages
6,012,904
Members
441,740
Latest member
Latrs

Share this page

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
Top