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:

Excel Facts

Repeat Last Command
Pressing F4 adds dollar signs when editing a formula. When not editing, F4 repeats last command.
Sort by date Sort by votes
The result will show like this

Col_ACol_BCol_CCol_DCol_ECol_FCol_GCol_HCol_ICol_JCol_KCol_LCol_MCol_NCol_OCol_PCol_QCol_RCol_S
Series 1122013540
Series 25641A2B

<tbody>
</tbody>
 
Upvote 0
Try this:-
NB:- This code will alter your sheet data.!!!
Code: 
[COLOR=navy]Sub[/COLOR] MG28Mar17
    [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
        [COLOR=navy]Set[/COLOR] Rng = Range(Range("C2"), Range("C" & 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, Dn.Offset(, 16)
        [COLOR=navy]Else[/COLOR]
            [COLOR=navy]Set[/COLOR] .Item(Dn.Value) = Union(.Item(Dn.Value), Dn.Offset(, 16))
            [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)
        [COLOR=navy]End[/COLOR] If
[COLOR=navy]Next[/COLOR]
[COLOR=navy]For[/COLOR] [COLOR=navy]Each[/COLOR] K [COLOR=navy]In[/COLOR] .keys
    .Item(K)(1).Resize(, .Item(K).Count).Value = Application.Transpose(.Item(K).Value)
[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] [COLOR=navy]With[/COLOR]
[COLOR=navy]End[/COLOR] [COLOR=navy]Sub[/COLOR]
Regards Mick
 
Last edited:
Upvote 0
Thanks mick . this is what i want but is it possible to retain the font format (like colour, bold or underline?)

MickG said:
Try this:-
NB:- This code will alter your sheet data.!!!
Code: 
[COLOR=navy]Sub[/COLOR] MG28Mar17
    [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
        [COLOR=navy]Set[/COLOR] Rng = Range(Range("C2"), Range("C" & 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, Dn.Offset(, 16)
        [COLOR=navy]Else[/COLOR]
            [COLOR=navy]Set[/COLOR] .Item(Dn.Value) = Union(.Item(Dn.Value), Dn.Offset(, 16))
            [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)
        [COLOR=navy]End[/COLOR] If
[COLOR=navy]Next[/COLOR]
[COLOR=navy]For[/COLOR] [COLOR=navy]Each[/COLOR] K [COLOR=navy]In[/COLOR] .keys
    .Item(K)(1).Resize(, .Item(K).Count).Value = Application.Transpose(.Item(K).Value)
[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] [COLOR=navy]With[/COLOR]
[COLOR=navy]End[/COLOR] [COLOR=navy]Sub[/COLOR]
Regards Mick
Click to expand...
 
Upvote 0
Try this:-
Code: 
[COLOR=navy]Sub[/COLOR] MG29Mar15
   [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
        [COLOR=navy]Set[/COLOR] Rng = Range(Range("C2"), Range("C" & 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, Nothing 
        [COLOR=navy]Else[/COLOR]
            [COLOR=navy]If[/COLOR] .Item(Dn.Value) [COLOR=navy]Is[/COLOR] Nothing [COLOR=navy]Then[/COLOR]
                [COLOR=navy]Set[/COLOR] .Item(Dn.Value) = Dn.Offset(, 16)
            [COLOR=navy]Else[/COLOR]
                [COLOR=navy]Set[/COLOR] .Item(Dn.Value) = Union(.Item(Dn.Value), Dn.Offset(, 16))
             [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)
        [COLOR=navy]End[/COLOR] If
[COLOR=navy]Next[/COLOR]
[COLOR=navy]For[/COLOR] [COLOR=navy]Each[/COLOR] K [COLOR=navy]In[/COLOR] .keys
   .Item(K).Copy
   .Item(K)(1).Offset(-1, 1).PasteSpecial Paste:=xlPasteAll, Transpose:=True
 [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] [COLOR=navy]With[/COLOR]
[COLOR=navy]End[/COLOR] [COLOR=navy]Sub[/COLOR]
Regards Mick
 
Last edited:
Upvote 0
Thank Mick! it works! thanks it help me alot :)


MickG said:
Try this:-
Code: 
[COLOR=navy]Sub[/COLOR] MG29Mar15
   [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
        [COLOR=navy]Set[/COLOR] Rng = Range(Range("C2"), Range("C" & 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, Nothing 
        [COLOR=navy]Else[/COLOR]
            [COLOR=navy]If[/COLOR] .Item(Dn.Value) [COLOR=navy]Is[/COLOR] Nothing [COLOR=navy]Then[/COLOR]
                [COLOR=navy]Set[/COLOR] .Item(Dn.Value) = Dn.Offset(, 16)
            [COLOR=navy]Else[/COLOR]
                [COLOR=navy]Set[/COLOR] .Item(Dn.Value) = Union(.Item(Dn.Value), Dn.Offset(, 16))
             [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)
        [COLOR=navy]End[/COLOR] If
[COLOR=navy]Next[/COLOR]
[COLOR=navy]For[/COLOR] [COLOR=navy]Each[/COLOR] K [COLOR=navy]In[/COLOR] .keys
   .Item(K).Copy
   .Item(K)(1).Offset(-1, 1).PasteSpecial Paste:=xlPasteAll, Transpose:=True
 [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] [COLOR=navy]With[/COLOR]
[COLOR=navy]End[/COLOR] [COLOR=navy]Sub[/COLOR]
Regards Mick
Click to expand...
 
Upvote 0
Hi MickG.

There is some error when i try to use it.

I make abit change like Change to D2 and Transpose @ row 14.

There is a runtime error 91 , when i click debug it say point error @ .Item(K).Copy


MickG said:
You're welcome
Click to expand...


Code: 
Sub MergeRow2Col()
   Dim Rng As Range, Dn As Range, n As Long, nRng As Range, K As Variant
        Set Rng = Range(Range("D2"), Range("D" & Rows.Count).End(xlUp))
            With CreateObject("scripting.dictionary")
                .CompareMode = vbTextCompare
    For Each Dn In Rng
        If Not .Exists(Dn.Value) Then
            .Add Dn.Value, Nothing
        Else
            If .Item(Dn.Value) Is Nothing Then
                Set .Item(Dn.Value) = Dn.Offset(, 14)
            Else
                Set .Item(Dn.Value) = Union(.Item(Dn.Value), Dn.Offset(, 14))
             End If
            If nRng Is Nothing Then Set nRng = Dn Else Set nRng = Union(nRng, Dn)
        End If
Next
For Each K In .keys
   .Item(K).Copy
   .Item(K)(1).Offset(-1, 1).PasteSpecial Paste:=xlPasteAll, Transpose:=True
 Next K
    If Not nRng Is Nothing Then nRng.EntireRow.Delete
End With
End Sub
 
Upvote 0
runtime error 91
object variable or with block variable not set
 
Upvote 0
the first code is working if i Change to D2 and Transpose @ row 14.
but it dont retain the font format (like colour, bold or underline).
 
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
489
sijpie
sijpie
O
  • Question
Moving data from a single column to get more row values to work with
2
Replies
11
Views
512
Peter_SSs
Peter_SSs
D
  • Question
Create Header Row From Data & Place Column Data Across 4 Columns
Replies
0
Views
419
dts_1234
D
Fergus
  • Question
Code to transfer data from one workbook to another
Replies
5
Views
456
Fluff
Fluff
B
  • Question
Data Extraction from an Array
2
Replies
13
Views
1K
DanteAmor
DanteAmor

Forum statistics

Threads
1,214,911
Messages
6,122,198
Members
449,072
Latest member
DW Draft

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