Move data from a row to column

H

harky

Active Member
Joined
Apr 8, 2010
Messages
405
Office Version
  1. 2021
  2. 2019
Platform
  1. Windows
Hi, i need some help. But not sure if someone able to help me.
I using excel 2010.

My Excel had total of 19 fix column.

Col_C is a series number while Col_S is a ''any number"
Possible to shift up (row to column) base on Col_S and delete repeated series no. on Col_C? while the rest col will be fill up with other information which is similar to Col_C


Col_ACol_BCol_CCol_DCol_ECol_FCol_GCol_HCol_ICol_JCol_KCol_LCol_MCol_NCol_OCol_PCol_QCol_RCol_S
Series 112
Series 120
Series 11
Series 135
Series 140
Series 223
Series 25
Series 264
Series 21A
Series 22B

<tbody>
</tbody>
 
Last edited:
Sort by date Sort by votes

Excel Facts

What do {} around a formula in the formula bar mean?
{Formula} means the formula was entered using Ctrl+Shift+Enter signifying an old-style array formula.
the result is same as post #2 but retain the font colour, bold, underline, highlight colour when it del the repeated base on D2
If i use the post #3 code. it wont retain the font colour, bold, underline, highlight colour when it del the repeated
Col_D is a series number while Col_R is a ''any number"


MickG said:
You need to show an example of your changed data with expected result.
Click to expand...
 
Last edited:
Upvote 0
Row 1 is header (Which will be replace with actual naming)
This is how the data look like
RxYHhAf.png


ColD is a series number (with font colour, underline, highlight)
ColR is a ''any number" (with font colour, underline, highlight)
The rest is data information.

Shift up (row to column) "any number" on ColR and delete repeated series no. base ColD


The result be will like this.
Ncf58zb.png
 
Upvote 0
Mick, i think i know why there is an error.

My series no. contain 1 or more than 1
the code had error when there is only 1 series.no and not able to ignore it thus it has an error.

Look at Col.D (Series no: 28228) - non repeat series no.
If i remove (Series no: 28228) row, the code is works since the rest of the series no. has more than 1.

Possible to get it fixed?

MickG said:
You need to show an example of your changed data with expected result.
Click to expand...
 
Last edited:
Upvote 0
And, if the series no. is in jumping order or in order , can i arrange it with same result?

sorry to post so much.
Rv3lmkz.png
 
Last edited:
Upvote 0
Try this:-
Code: 
[COLOR="Navy"]Sub[/COLOR] MG05Apr47
[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] nRng [COLOR="Navy"]As[/COLOR] Range, K [COLOR="Navy"]As[/COLOR] Variant, Q [COLOR="Navy"]As[/COLOR] Variant
        [COLOR="Navy"]Set[/COLOR] Rng = Range(Range("D2"), Range("D" & Rows.Count).End(xlUp))
            [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, Array(1, Nothing, Dn.Offset(, 14))
        [COLOR="Navy"]Else[/COLOR]
           Q = .Item(Dn.Value)
            Q(0) = Q(0) + 1
            
            [COLOR="Navy"]If[/COLOR] Q(1) [COLOR="Navy"]Is[/COLOR] Nothing [COLOR="Navy"]Then[/COLOR]
                [COLOR="Navy"]Set[/COLOR] Q(1) = Dn.Offset(, 14)
            [COLOR="Navy"]Else[/COLOR]
                [COLOR="Navy"]Set[/COLOR] Q(1) = Union(Q(1), Dn.Offset(, 14))
             [COLOR="Navy"]End[/COLOR] If
            [COLOR="Navy"]If[/COLOR] nRng [COLOR="Navy"]Is[/COLOR] Nothing [COLOR="Navy"]Then[/COLOR] [COLOR="Navy"]Set[/COLOR] nRng = Dn Else [COLOR="Navy"]Set[/COLOR] nRng = Union(nRng, Dn)
          .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"]If[/COLOR] Not .Item(K)(1) [COLOR="Navy"]Is[/COLOR] Nothing [COLOR="Navy"]Then[/COLOR]
        .Item(K)(1).Copy
        [COLOR="Navy"]If[/COLOR] .Item(K)(0) > 1 [COLOR="Navy"]Then[/COLOR]
           .Item(K)(2).Offset(, 1).PasteSpecial Paste:=xlPasteAll, Transpose:=True
        [COLOR="Navy"]End[/COLOR] If
  [COLOR="Navy"]End[/COLOR] If
[COLOR="Navy"]Next[/COLOR] K
   
    [COLOR="Navy"]If[/COLOR] Not nRng [COLOR="Navy"]Is[/COLOR] Nothing [COLOR="Navy"]Then[/COLOR] nRng.EntireRow.Delete
[COLOR="Navy"]End[/COLOR] With
[COLOR="Navy"]End[/COLOR] [COLOR="Navy"]Sub[/COLOR]
Regards Mick
 
Upvote 0
thx thx. it work like what i want. Can i request one more for sorting?

Do you think is better to sort
ColD (Sort Smallest to Largest), then ColR Sort Smallest to Largest before do the shift?

MickG said:
Try this:-
Code: 
[COLOR=Navy]Sub[/COLOR] MG05Apr47
[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] nRng [COLOR=Navy]As[/COLOR] Range, K [COLOR=Navy]As[/COLOR] Variant, Q [COLOR=Navy]As[/COLOR] Variant
        [COLOR=Navy]Set[/COLOR] Rng = Range(Range("D2"), Range("D" & Rows.Count).End(xlUp))
            [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, Array(1, Nothing, Dn.Offset(, 14))
        [COLOR=Navy]Else[/COLOR]
           Q = .Item(Dn.Value)
            Q(0) = Q(0) + 1
            
            [COLOR=Navy]If[/COLOR] Q(1) [COLOR=Navy]Is[/COLOR] Nothing [COLOR=Navy]Then[/COLOR]
                [COLOR=Navy]Set[/COLOR] Q(1) = Dn.Offset(, 14)
            [COLOR=Navy]Else[/COLOR]
                [COLOR=Navy]Set[/COLOR] Q(1) = Union(Q(1), Dn.Offset(, 14))
             [COLOR=Navy]End[/COLOR] If
            [COLOR=Navy]If[/COLOR] nRng [COLOR=Navy]Is[/COLOR] Nothing [COLOR=Navy]Then[/COLOR] [COLOR=Navy]Set[/COLOR] nRng = Dn Else [COLOR=Navy]Set[/COLOR] nRng = Union(nRng, Dn)
          .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]If[/COLOR] Not .Item(K)(1) [COLOR=Navy]Is[/COLOR] Nothing [COLOR=Navy]Then[/COLOR]
        .Item(K)(1).Copy
        [COLOR=Navy]If[/COLOR] .Item(K)(0) > 1 [COLOR=Navy]Then[/COLOR]
           .Item(K)(2).Offset(, 1).PasteSpecial Paste:=xlPasteAll, Transpose:=True
        [COLOR=Navy]End[/COLOR] If
  [COLOR=Navy]End[/COLOR] If
[COLOR=Navy]Next[/COLOR] K
   
    [COLOR=Navy]If[/COLOR] Not nRng [COLOR=Navy]Is[/COLOR] Nothing [COLOR=Navy]Then[/COLOR] nRng.EntireRow.Delete
[COLOR=Navy]End[/COLOR] With
[COLOR=Navy]End[/COLOR] [COLOR=Navy]Sub[/COLOR]
Regards Mick
Click to expand...
 
Upvote 0
thx thx. it work like what i want. Sorry, can i request one more for sorting?

Do sort
ColD (Sort Smallest to Largest), then ColR Sort Smallest to Largest before do the shift up col.

possible to be done :/

MickG said:
Try this:-
Code: 
[COLOR=Navy]Sub[/COLOR] MG05Apr47
[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] nRng [COLOR=Navy]As[/COLOR] Range, K [COLOR=Navy]As[/COLOR] Variant, Q [COLOR=Navy]As[/COLOR] Variant
        [COLOR=Navy]Set[/COLOR] Rng = Range(Range("D2"), Range("D" & Rows.Count).End(xlUp))
            [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, Array(1, Nothing, Dn.Offset(, 14))
        [COLOR=Navy]Else[/COLOR]
           Q = .Item(Dn.Value)
            Q(0) = Q(0) + 1
            
            [COLOR=Navy]If[/COLOR] Q(1) [COLOR=Navy]Is[/COLOR] Nothing [COLOR=Navy]Then[/COLOR]
                [COLOR=Navy]Set[/COLOR] Q(1) = Dn.Offset(, 14)
            [COLOR=Navy]Else[/COLOR]
                [COLOR=Navy]Set[/COLOR] Q(1) = Union(Q(1), Dn.Offset(, 14))
             [COLOR=Navy]End[/COLOR] If
            [COLOR=Navy]If[/COLOR] nRng [COLOR=Navy]Is[/COLOR] Nothing [COLOR=Navy]Then[/COLOR] [COLOR=Navy]Set[/COLOR] nRng = Dn Else [COLOR=Navy]Set[/COLOR] nRng = Union(nRng, Dn)
          .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]If[/COLOR] Not .Item(K)(1) [COLOR=Navy]Is[/COLOR] Nothing [COLOR=Navy]Then[/COLOR]
        .Item(K)(1).Copy
        [COLOR=Navy]If[/COLOR] .Item(K)(0) > 1 [COLOR=Navy]Then[/COLOR]
           .Item(K)(2).Offset(, 1).PasteSpecial Paste:=xlPasteAll, Transpose:=True
        [COLOR=Navy]End[/COLOR] If
  [COLOR=Navy]End[/COLOR] If
[COLOR=Navy]Next[/COLOR] K
   
    [COLOR=Navy]If[/COLOR] Not nRng [COLOR=Navy]Is[/COLOR] Nothing [COLOR=Navy]Then[/COLOR] nRng.EntireRow.Delete
[COLOR=Navy]End[/COLOR] With
[COLOR=Navy]End[/COLOR] [COLOR=Navy]Sub[/COLOR]
Regards Mick
Click to expand...
 
Upvote 0
Hi Mick. Sorry. Is sort row.
Just like we do sorting using excel?
sorting ROW small to large base on COL D then COL R as the ID number is input in this two columns.

I suppose the row will be sort sort together with d and r?

This is how the startup data look like.
Rv3lmkz.png


MickG said:
Does that mean you don't need the columns in between (D & R) to be sorted???
Click to expand...
 
Last edited:
Upvote 0
You must log in or register to reply here.

Similar threads

S
  • Question
VBA Sort Columns by Number in a Row on every Sheet in Workbook and Combine Data from all Sheets
Replies
6
Views
477
sijpie
sijpie
O
  • Question
Moving data from a single column to get more row values to work with
2
Replies
11
Views
510
Peter_SSs
Peter_SSs
D
  • Question
Create Header Row From Data & Place Column Data Across 4 Columns
Replies
0
Views
417
dts_1234
D
Fergus
  • Question
Code to transfer data from one workbook to another
Replies
5
Views
455
Fluff
Fluff
B
  • Question
Data Extraction from an Array
2
Replies
13
Views
1K
DanteAmor
DanteAmor

Forum statistics

Threads
1,214,590
Messages
6,120,423
Members
448,961
Latest member
nzskater

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