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
Hi Mick,

Sorry. i think i spotted my error. I put YES instead of Yes. :)
i dont know that the word is so sensitives

harky said:
Hi Mick,

tried this, but It delete everything except header .
Click to expand...
 
Last edited:
Upvote 0

Excel Facts

Which came first: VisiCalc or Lotus 1-2-3?
Dan Bricklin and Bob Frankston debuted VisiCalc in 1979 as a Visible Calculator. Lotus 1-2-3 debuted in the early 1980's, from Mitch Kapor.
Hi Mick, i tried the script.

The series no. 55041 was deleted.
It suppose not to delete 55041 even though ColQ is empty.

This is my data,
Eb0DWfR.jpg


after run the vb script. This is result.
YavtqCC.jpg


MickG said:
Try this:-
Code: 
[COLOR=Navy]Sub[/COLOR] MG10Apr11
[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, Temp [COLOR=Navy]As[/COLOR] [COLOR=Navy]String[/COLOR]
        [COLOR=Navy]Set[/COLOR] Rng = Range(Range("D2"), Range("D" & Rows.Count).End(xlUp))
          [COLOR=Navy]With[/COLOR] Rng.Offset(, -3).Resize(Rng.Count + 1, 18)
            .Sort Key1:=.Range("D1"), Key2:=.Range("R1"), Header:=xlYes
        [COLOR=Navy]End[/COLOR] With
            [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, Dn.Offset(, 14), Dn.Offset(, 14), Dn.Offset(, 14))
        [COLOR=Navy]Else[/COLOR]
           Q = .Item(Dn.Value)
            Q(0) = Q(0) + 1
            [COLOR=Navy]If[/COLOR] Dn.Offset(, 13) = "Yes" [COLOR=Navy]Then[/COLOR] [COLOR=Navy]Set[/COLOR] Q(3) = Dn.Offset(, 14)
                [COLOR=Navy]Set[/COLOR] Q(1) = Union(Q(1), Dn.Offset(, 14))
          .Item(Dn.Value) = Q
        [COLOR=Navy]End[/COLOR] If
          [COLOR=Navy]If[/COLOR] Not Dn.Offset(, 13) = "Yes" [COLOR=Navy]Then[/COLOR]
            [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
   [COLOR=Navy]If[/COLOR] Not .Item(K)(1) [COLOR=Navy]Is[/COLOR] Nothing [COLOR=Navy]Then[/COLOR]
        .Item(K)(1).Copy
        .Item(K)(3).Offset(, 1).PasteSpecial Paste:=xlPasteAll, Transpose:=True
  [COLOR=Navy]End[/COLOR] If
[COLOR=Navy]Next[/COLOR] K
     Temp = Range("R1").Value
        Columns("R:R").Delete
    Range("R1").Value = Temp
    [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...
 
Last edited:
Upvote 0
HI mick,

For 55041, there is no Yes.
Q will be filled by either Yes or blank.


The final result should be like this
Ptem1GG.png


MickG said:
Why has it not got a "Yes" in column "Q" for 55041 ???
Click to expand...
 
Last edited:
Upvote 0
So if there is a "Yes" in column "Q", use that line for the results and if there are just blanks for a particular unique value then use the first Row of those values for the results. Is that correct ???
 
Upvote 0
This is my data,

vb will sort D and R (Sort Smallest to Largest); Q will be filled by either Yes or blank
it will transposed R (Shift up row to column) and delete repeated D

one series number will had only 1 row as a result after transposed, sorting, yes or blank.

Eb0DWfR.jpg



Final result will be like this
Ptem1GG.png
 
Last edited:
Upvote 0
I suppose but one series number will had only 1 row as a result after transposed, sorting, yes or blank.
No series number should be deleted.

MickG said:
So if there is a "Yes" in column "Q", use that line for the results and if there are just blanks for a particular unique value then use the first Row of those values for the results. Is that correct ???
Click to expand...
 
Last edited:
Upvote 0
Try this:-
Code: 
[COLOR="Navy"]Sub[/COLOR] MG11Apr19
[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, Temp [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]String[/COLOR]
        [COLOR="Navy"]Set[/COLOR] Rng = Range(Range("D2"), Range("D" & Rows.Count).End(xlUp))
          [COLOR="Navy"]With[/COLOR] Rng.Offset(, -3).Resize(Rng.Count + 1, 18)
            .Sort Key1:=.Range("D1"), Key2:=.Range("R1"), Header:=xlYes
        [COLOR="Navy"]End[/COLOR] With
            [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, Dn.Offset(, 14), Dn.Offset(, 14))
        [COLOR="Navy"]Else[/COLOR]
           Q = .Item(Dn.Value)
            Q(0) = Q(0) + 1
            [COLOR="Navy"]If[/COLOR] Dn.Offset(, 13) = "Yes" [COLOR="Navy"]Then[/COLOR] [COLOR="Navy"]Set[/COLOR] Q(2) = Dn.Offset(, 14)
                [COLOR="Navy"]Set[/COLOR] Q(1) = Union(Q(1), Dn.Offset(, 14))
           .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
        .Item(K)(2).Offset(, 1).PasteSpecial Paste:=xlPasteAll, Transpose:=True
  [COLOR="Navy"]End[/COLOR] If
[COLOR="Navy"]Next[/COLOR] K
     Temp = Range("R1").Value
        Columns("R:R").Delete
    Range("R1").Value = Temp
   Rng.Offset(, 14).SpecialCells(xlCellTypeBlanks).EntireRow.Delete
[COLOR="Navy"]End[/COLOR] [COLOR="Navy"]With[/COLOR]
[COLOR="Navy"]End[/COLOR] [COLOR="Navy"]Sub[/COLOR]
Regards Mick
 
Upvote 0
Hi Mick, yes this work great! :ROFLMAO: Really appreciated your help ! sorry for the confuse.


MickG said:
Try this:-
Code: 
[COLOR=Navy]Sub[/COLOR] MG11Apr19
[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, Temp [COLOR=Navy]As[/COLOR] [COLOR=Navy]String[/COLOR]
        [COLOR=Navy]Set[/COLOR] Rng = Range(Range("D2"), Range("D" & Rows.Count).End(xlUp))
          [COLOR=Navy]With[/COLOR] Rng.Offset(, -3).Resize(Rng.Count + 1, 18)
            .Sort Key1:=.Range("D1"), Key2:=.Range("R1"), Header:=xlYes
        [COLOR=Navy]End[/COLOR] With
            [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, Dn.Offset(, 14), Dn.Offset(, 14))
        [COLOR=Navy]Else[/COLOR]
           Q = .Item(Dn.Value)
            Q(0) = Q(0) + 1
            [COLOR=Navy]If[/COLOR] Dn.Offset(, 13) = "Yes" [COLOR=Navy]Then[/COLOR] [COLOR=Navy]Set[/COLOR] Q(2) = Dn.Offset(, 14)
                [COLOR=Navy]Set[/COLOR] Q(1) = Union(Q(1), Dn.Offset(, 14))
           .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
        .Item(K)(2).Offset(, 1).PasteSpecial Paste:=xlPasteAll, Transpose:=True
  [COLOR=Navy]End[/COLOR] If
[COLOR=Navy]Next[/COLOR] K
     Temp = Range("R1").Value
        Columns("R:R").Delete
    Range("R1").Value = Temp
   Rng.Offset(, 14).SpecialCells(xlCellTypeBlanks).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
You must log in or register to reply here.

Similar threads

H
  • Question
Extract Data from Single Cell. Column is Constant. Number of Rows Involved Changes. Number of Rows Within a Single Cell Can be 1 Up to 9
Replies
6
Views
120
helpmeplz_
H
S
  • Question
VBA Sort Columns by Number in a Row on every Sheet in Workbook and Combine Data from all Sheets
Replies
6
Views
492
sijpie
sijpie
O
  • Question
Moving data from a single column to get more row values to work with
2
Replies
11
Views
518
Peter_SSs
Peter_SSs
D
  • Question
Create Header Row From Data & Place Column Data Across 4 Columns
Replies
0
Views
421
dts_1234
D
Fergus
  • Question
Code to transfer data from one workbook to another
Replies
5
Views
457
Fluff
Fluff

Forum statistics

Threads
1,215,208
Messages
6,123,644
Members
449,111
Latest member
ghennedy

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