VBA Macro - Transpose with conditions

M

marcelo_abreu

New Member
Joined
Feb 23, 2018
Messages
3
So I need your help! Firstly I am a student and don't really know much about VBA, because my teacher skipped those classes, whatever...

I have a table with a long number of rows and data in columns.I wanna transpose them to rows and deleting duplicates, so it's better to review the data.
I'm thinking about doing this with a macro of course.

The table I got is similar to the next one:
Unit ProcudureUnit OperationOperation ParameterParameter ValueEng. UnitsOrigin
17CH43_SD1251_STARTUPBEGIN_SD:1CIP_STRestValue
17CH43_SD1251_STARTUPBEGIN_SD:1CND_STRestValue
17CH43_SD1251_STARTUPBEGIN_SD:1DESC1minValue
17CH43_SD1251_STARTUPBEGIN_SD:1DRY_STonValue
17CH43_SD1251_STARTUPDRYING_SD:1CIP_STActiveValue
17CH43_SD1251_STARTUPDRYING_SD:1CND_STRestValue
17CH43_SD1251_STARTUPDRYING_SD:1DESC2minValue
17CH43_SD1251_STARTUPDRYING_SD:1DRY_SToffValue
17CH43_SD1251_STARTUPDRYING_SD:2CIP_STRestValue
17CH43_SD1251_STARTUPDRYING_SD:2CND_STActiveValue
17CH43_SD1251_STARTUPDRYING_SD:2DESC3minValue
17CH43_SD1251_STARTUPDRYING_SD:2DRY_SToffValue
17CH43_SD1251_STARTUPOPCHECK_SD:1DESC4minValue
17CH43_SD1251_STARTUPOPCHECK_SD:1B070_OUT_MAX100%Value
17CH43_SD1251_STARTUPOPCHECK_SD:1B070_OUT_MIN10%Value
17CH43_SD1251_STARTUPOPCHECK_SD:1Q4TYPEnoneValue
17CH43_SD1251_STARTUPSETUP_SD:1B070_OUT_MAX50%Value
17CH43_SD1251_STARTUPSETUP_SD:1B070_OUT_MIN20%Value
17CH43_SD1251_STARTUPSETUP_SD:1DESC5minValue

<tbody>
</tbody>

So with a macro and a table like this (the actual table has over 300 rows and more operations and procedures):
-----

Unit Procedure17CH43_SD1251_STARTUP17CH43_SD1251_STARTUP17CH43_SD1251_STARTUP17CH43_SD1251_STARTUP17CH43_SD1251_STARTUP17CH43_SD1251_STARTUP17CH43_SD1251_STARTUP
Unit OperationBEGIN_SD:1DRYING_SD:1DRYING_SD:2OPCHECK_SD:1SETUP_SD:1
Operation ParameterParameter ValueParameter ValueParameter ValueParameter ValueParameter ValueEng. UnitsOrigin
CIP_STRestActiveRestValue
CND_STRestRestActiveValue
DESC12345minValue
DRY_STonoffonValue
Q4TYPEnoneValue
B070_OUT_MAX10050%Value
B070_OUT_MIN1020%Value

<tbody>
</tbody>

This would be the kind of result I'm tryna work on but can't figure it out.
Don't really know if it's possible.. If not I'd like some help on just the operation parameter and parameter value.

Excuse my english in any case of bad spelling, I'm portuguese.
Thank you, Marcelo!

 

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
Try this for results on sheet2.
This works for the thread data, but I fancy your real data might be somewhat different !!!!!

Code: 
[COLOR=navy]Sub[/COLOR] MG23Feb04
[COLOR=navy]Dim[/COLOR] Dn          [COLOR=navy]As[/COLOR] Range
[COLOR=navy]Dim[/COLOR] n           [COLOR=navy]As[/COLOR] [COLOR=navy]Long,[/COLOR] Ac [COLOR=navy]As[/COLOR] [COLOR=navy]Long[/COLOR]
[COLOR=navy]Dim[/COLOR] Rng         [COLOR=navy]As[/COLOR] Range
[COLOR=navy]Dim[/COLOR] Dic         [COLOR=navy]As[/COLOR] Object
[COLOR=navy]Dim[/COLOR] k           [COLOR=navy]As[/COLOR] Variant
[COLOR=navy]Dim[/COLOR] p           [COLOR=navy]As[/COLOR] Variant
[COLOR=navy]Dim[/COLOR] c           [COLOR=navy]As[/COLOR] [COLOR=navy]Long[/COLOR]
[COLOR=navy]Dim[/COLOR] Sp          [COLOR=navy]As[/COLOR] Variant
[COLOR=navy]Dim[/COLOR] Txt         [COLOR=navy]As[/COLOR] [COLOR=navy]String[/COLOR]
   [COLOR=navy]Set[/COLOR] Rng = Range(Range("A1"), Range("A" & Rows.Count).End(xlUp))
    [COLOR=navy]Set[/COLOR] Dic = CreateObject("Scripting.Dictionary")
        Dic.CompareMode = 1
            [COLOR=navy]With[/COLOR] CreateObject("scripting.dictionary")
                .CompareMode = vbTextCompare
   
   [COLOR=navy]For[/COLOR] [COLOR=navy]Each[/COLOR] Dn [COLOR=navy]In[/COLOR] Rng
            Txt = Dn.Value & "," & Dn.Offset(, 1).Value
            [COLOR=navy]If[/COLOR] Not Dic.exists(Txt) [COLOR=navy]Then[/COLOR]
                [COLOR=navy]Set[/COLOR] Dic(Txt) = CreateObject("Scripting.Dictionary")
            [COLOR=navy]End[/COLOR] If
            [COLOR=navy]If[/COLOR] Not Dn = Rng(1) [COLOR=navy]Then[/COLOR] .Item(Dn.Offset(, 2).Value) = Empty
                Dic(Txt).Add (Dn.Offset(, 2).Value), Dn
    [COLOR=navy]Next[/COLOR] Dn
   
   
   ReDim ray(1 To Rng.Count, 1 To Dic.Count + 2)
   c = 3
    [COLOR=navy]For[/COLOR] [COLOR=navy]Each[/COLOR] k [COLOR=navy]In[/COLOR] Dic.keys
        Ac = Ac + 1
        Sp = Split(k, ",")
        ray(1, Ac) = Sp(0)
        ray(2, Ac) = Sp(1)
        ray(3, Ac) = IIf(Ac = 1, "Operation Parameter", "Parameter Value")
        ray(1, Dic.Count + 1) = Sp(0)
        ray(1, Dic.Count + 2) = Sp(0)
        ray(3, UBound(ray, 2) - 1) = "Eng.Units"
        ray(3, UBound(ray, 2)) = "Origin"
    [COLOR=navy]Next[/COLOR] k
       
       [COLOR=navy]For[/COLOR] [COLOR=navy]Each[/COLOR] p [COLOR=navy]In[/COLOR] .keys: c = c + 1: ray(c, 1) = p: [COLOR=navy]Next[/COLOR] p
    
[COLOR=navy]End[/COLOR] With
[COLOR=navy]Dim[/COLOR] R [COLOR=navy]As[/COLOR] Range
[COLOR=navy]For[/COLOR] Ac = 2 To UBound(ray, 2) - 2
    [COLOR=navy]For[/COLOR] n = 4 To c
        [COLOR=navy]If[/COLOR] Dic(ray(1, Ac) & "," & ray(2, Ac)).exists(ray(n, 1)) [COLOR=navy]Then[/COLOR]
                [COLOR=navy]Set[/COLOR] R = Dic(ray(1, Ac) & "," & ray(2, Ac)).Item(ray(n, 1))
                ray(n, Ac) = R.Offset(, 3).Value
                [COLOR=navy]If[/COLOR] R.Offset(, 4).Value <> "" [COLOR=navy]Then[/COLOR] ray(n, UBound(ray, 2) - 1) = R.Offset(, 4)
                [COLOR=navy]If[/COLOR] R.Offset(, 5).Value <> "" [COLOR=navy]Then[/COLOR] ray(n, UBound(ray, 2)) = R.Offset(, 5)
        [COLOR=navy]End[/COLOR] If
    [COLOR=navy]Next[/COLOR] n
[COLOR=navy]Next[/COLOR] Ac
 
[COLOR=navy]With[/COLOR] Sheets("Sheet2").Range("A1").Resize(c, UBound(ray, 2))
    .Value = ray
    .Columns.AutoFit
    .Borders.Weight = 2
[COLOR=navy]End[/COLOR] [COLOR=navy]With[/COLOR]
[COLOR=navy]End[/COLOR] [COLOR=navy]Sub[/COLOR]
Regards Mick
 
Last edited:
Upvote 0
I try to run it on sheet 1 and it appears a window saying "run-time error 457: this key is already associated with an element of this collection" i press debug and it highlights the code "Dic(Txt).Add (Dn.Offset(, 2).Value), Dn" , any tips on how to fix it?

And

If I try to run it on Sheet 2 it appears a window saying "run-time error 9: subscript out of range" i press debug and it highlights the code "ray(2, Ac) = Sp(1)", any tips on how to fix it?

Thanks a lot, you guys are amazing!
Marcelo abreu
 
Upvote 0
You must log in or register to reply here.

Similar threads

P
  • Solved
Counter in For Each loop
Replies
2
Views
197
Possum17
P
P
  • Question
Help with Vba Code
Replies
3
Views
161
Coyotex3
C
C
  • Question
Loop validation, copy output from same range and paste in different ranges
Replies
1
Views
392
RoryA
RoryA
T
  • Question
VBA Macro running, but not saving to Sharepoint
Replies
3
Views
564
Fluff
Fluff
K
  • Question
Excel Macro Newbie in need of help
Replies
1
Views
317
KaP76
K

Forum statistics

Threads
1,215,045
Messages
6,122,836
Members
449,096
Latest member
Erald

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
Back
Top