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,
i notice there is something happen if the script was click more than twice.
Like ColS has number was deleted. Because everytime when activated, the marco will move ColR to ColS.
Is it possible to prevent tht that?
had msg or whatever?


MickG said:
Great news !!!
You're very welcome
Click to expand...
 
Last edited:
Upvote 0

Excel Facts

How to calculate loan payments in Excel?
Use the PMT function: =PMT(5%/12,60,-25000) is for a $25,000 loan, 5% annual interest, 60 month loan.
Possible to add MSG, if there is anything on Col S, T, U onwards.
Have a popup MSG say "MACRO aborted, error on Col S?" MACRO wont run till it fixed.

So this will avoid overlay on ColS with ColR number if MACRO run more than twice.
 
Last edited:
Upvote 0
Try adding the lines in Red as shown below:-
Code: 
[COLOR=navy]Sub[/COLOR] MG16Apr21
'[COLOR=green][B]Dim Rng As Range, Dn As Range, n As Long, nRng As Range, K As Variant, Q As Variant, Temp As String[/B][/COLOR]
  [B][COLOR=#FF0000]   If Application.CountA(Range("S:S")) = 0 Then[/COLOR][/B]
'[COLOR=green][B]        Set Rng = Range(Range("D2"), Range("D" & Rows.Count).End(xlUp))[/B][/COLOR]
'[COLOR=green][B]          With Rng.Offset(, -3).Resize(Rng.Count + 1, 18)[/B][/COLOR]
'[COLOR=green][B]            .Sort Key1:=.Range("D1"), Key2:=.Range("R1"), Header:=xlYes[/B][/COLOR]
'[COLOR=green][B]        End With[/B][/COLOR]
'[COLOR=green][B]            With CreateObject("scripting.dictionary")[/B][/COLOR]
'[COLOR=green][B]                .CompareMode = vbTextCompare[/B][/COLOR]
'[COLOR=green][B]    For Each Dn In Rng[/B][/COLOR]
'[COLOR=green][B]        If Not .Exists(Dn.Value) Then[/B][/COLOR]
'[COLOR=green][B]            .Add Dn.Value, Array(1, Dn.Offset(, 14), Dn.Offset(, 14))[/B][/COLOR]
'[COLOR=green][B]        Else[/B][/COLOR]
'[COLOR=green][B]           Q = .Item(Dn.Value)[/B][/COLOR]
'[COLOR=green][B]            Q(0) = Q(0) + 1[/B][/COLOR]
'[COLOR=green][B]            If Dn.Offset(, 13) = "Yes" Then Set Q(2) = Dn.Offset(, 14)[/B][/COLOR]
'[COLOR=green][B]                Set Q(1) = Union(Q(1), Dn.Offset(, 14))[/B][/COLOR]
'[COLOR=green][B]           .Item(Dn.Value) = Q[/B][/COLOR]
'[COLOR=green][B]        End If[/B][/COLOR]
'[COLOR=green][B]Next[/B][/COLOR]
'[COLOR=green][B]For Each K In .keys[/B][/COLOR]
'[COLOR=green][B]   If Not .Item(K)(1) Is Nothing Then[/B][/COLOR]
'[COLOR=green][B]        .Item(K)(1).Copy[/B][/COLOR]
'[COLOR=green][B]        .Item(K)(2).Offset(, 1).PasteSpecial Paste:=xlPasteAll, Transpose:=True[/B][/COLOR]
'[COLOR=green][B]  End If[/B][/COLOR]
'[COLOR=green][B]Next K[/B][/COLOR]
'[COLOR=green][B]     Temp = Range("R1").Value[/B][/COLOR]
'[COLOR=green][B]        Columns("R:R").Delete[/B][/COLOR]
'[COLOR=green][B]    Range("R1").Value = Temp[/B][/COLOR]
'[COLOR=green][B]   Rng.Offset(, 14).SpecialCells(xlCellTypeBlanks).EntireRow.Delete[/B][/COLOR]
'[COLOR=green][B]End With[/B][/COLOR]
[B][COLOR=#FF0000]Else
    MsgBox "MACRO aborted, error on Col S"
End If[/COLOR][/B]
[COLOR=navy]End[/COLOR] [COLOR=navy]Sub[/COLOR]
Regards Mick
 
Last edited:
Upvote 0
Thanks it works but

can i add in another msg?

If error MsgBox "MACRO aborted, error on Col S"
if no error, once MACRO ran finish, it end with Msgbox "Pls process to step 2"

MickG said:
Try adding the lines in Red as shown below:-
Code: 
[COLOR=navy]Sub[/COLOR] MG16Apr21
'[COLOR=green][B]Dim Rng As Range, Dn As Range, n As Long, nRng As Range, K As Variant, Q As Variant, Temp As String[/B][/COLOR]
  [B][COLOR=#FF0000]   If Application.CountA(Range("S:S")) = 0 Then[/COLOR][/B]
'[COLOR=green][B]        Set Rng = Range(Range("D2"), Range("D" & Rows.Count).End(xlUp))[/B][/COLOR]
'[COLOR=green][B]          With Rng.Offset(, -3).Resize(Rng.Count + 1, 18)[/B][/COLOR]
'[COLOR=green][B]            .Sort Key1:=.Range("D1"), Key2:=.Range("R1"), Header:=xlYes[/B][/COLOR]
'[COLOR=green][B]        End With[/B][/COLOR]
'[COLOR=green][B]            With CreateObject("scripting.dictionary")[/B][/COLOR]
'[COLOR=green][B]                .CompareMode = vbTextCompare[/B][/COLOR]
'[COLOR=green][B]    For Each Dn In Rng[/B][/COLOR]
'[COLOR=green][B]        If Not .Exists(Dn.Value) Then[/B][/COLOR]
'[COLOR=green][B]            .Add Dn.Value, Array(1, Dn.Offset(, 14), Dn.Offset(, 14))[/B][/COLOR]
'[COLOR=green][B]        Else[/B][/COLOR]
'[COLOR=green][B]           Q = .Item(Dn.Value)[/B][/COLOR]
'[COLOR=green][B]            Q(0) = Q(0) + 1[/B][/COLOR]
'[COLOR=green][B]            If Dn.Offset(, 13) = "Yes" Then Set Q(2) = Dn.Offset(, 14)[/B][/COLOR]
'[COLOR=green][B]                Set Q(1) = Union(Q(1), Dn.Offset(, 14))[/B][/COLOR]
'[COLOR=green][B]           .Item(Dn.Value) = Q[/B][/COLOR]
'[COLOR=green][B]        End If[/B][/COLOR]
'[COLOR=green][B]Next[/B][/COLOR]
'[COLOR=green][B]For Each K In .keys[/B][/COLOR]
'[COLOR=green][B]   If Not .Item(K)(1) Is Nothing Then[/B][/COLOR]
'[COLOR=green][B]        .Item(K)(1).Copy[/B][/COLOR]
'[COLOR=green][B]        .Item(K)(2).Offset(, 1).PasteSpecial Paste:=xlPasteAll, Transpose:=True[/B][/COLOR]
'[COLOR=green][B]  End If[/B][/COLOR]
'[COLOR=green][B]Next K[/B][/COLOR]
'[COLOR=green][B]     Temp = Range("R1").Value[/B][/COLOR]
'[COLOR=green][B]        Columns("R:R").Delete[/B][/COLOR]
'[COLOR=green][B]    Range("R1").Value = Temp[/B][/COLOR]
'[COLOR=green][B]   Rng.Offset(, 14).SpecialCells(xlCellTypeBlanks).EntireRow.Delete[/B][/COLOR]
'[COLOR=green][B]End With[/B][/COLOR]
[B][COLOR=#FF0000]Else
    MsgBox "MACRO aborted, error on Col S"
End If[/COLOR][/B]
[COLOR=navy]End[/COLOR] [COLOR=navy]Sub[/COLOR]
Regards Mick
Click to expand...
 
Last edited:
Upvote 0
Hi bro, i need some help to edit this current code :(

I added 2 more row (Which is Col I & Q)

DRjTPZP.png


So The Col R (Old) had shift to (Col T)


and Col_Q only has Yes or empty , no longer need (Can remove the code for this?)
Can ignore Col Q? If Dn.Offset(, 13) = "Yes"




MickG said:
You can add your second message just above the "Else" in red !!!!
Click to expand...
 
Upvote 0
Hi bro, i need some help to edit this current code
frown.png


I added 2 more row (Which is Col I & Q)

DRjTPZP.png


So The Col R (Old) had shift to (Col T)


The Col Q (Which is now Col S) will be filled by actual data (with data or empty)

Can change the Col Q (Which is now Col S), instead of using 'Yes', i want to use the actual data
There will be actual data or blank.




 
Last edited:
Upvote 0
i somehow anyhow and mange to get it fix but i am not very sure?

Changed the one in red.

Code: 
Sub MG11Apr19()


'START of confirmation message box'
response = MsgBox("Run Macro?", vbYesNo)
If response = vbNo Then
    MsgBox ("Macro Canceled!")
    Exit Sub
End If
'END of confirmation message box'


Dim Rng As Range, Dn As Range, n As Long, nRng As Range, K As Variant, Q As Variant, Temp As String
        If Application.CountA(Range("[COLOR=#ff0000]U:U[/COLOR]")) = 0 Then
        Set Rng = Range(Range("D1"), Range("D" & Rows.Count).End(xlUp))
        
          With Rng.Offset(, -1).Resize(Rng.Count + 1, [COLOR=#ff0000]20[/COLOR])
            .Sort Key1:=.Range("D1"), Key2:=.Range("[COLOR=#ff0000]T1[/COLOR]"), Header:=xlYes
        End With
            With CreateObject("scripting.dictionary")
                .CompareMode = vbTextCompare
    For Each Dn In Rng
        If Not .Exists(Dn.Value) Then
        
            .Add Dn.Value, Array(1, Dn.Offset(, [COLOR=#ff0000]16[/COLOR]), Dn.Offset(, [COLOR=#ff0000]16[/COLOR]))
        Else
           Q = .Item(Dn.Value)
            Q(0) = Q(0) + 1
[COLOR=#ff0000]            If Dn.Offset(, 15) <> "" Then Set Q(2) = Dn.Offset(, 16)[/COLOR]
           'If Dn.Offset(, 15) = "Yes" Then Set Q(2) = Dn.Offset(, 16) '<- if contain Yes
                Set Q(1) = Union(Q(1), Dn.Offset(, [COLOR=#ff0000]16[/COLOR]))
           .Item(Dn.Value) = Q
        End If
Next
For Each K In .keys
   If Not .Item(K)(1) Is Nothing Then
        .Item(K)(1).Copy
        .Item(K)(2).Offset(, 1).PasteSpecial Paste:=xlPasteAll, Transpose:=True
  End If
Next K


'errormsg'
On Error GoTo ErrorMSG
'START: Error MSG'


        Temp = Range("[COLOR=#ff0000]T1[/COLOR]").Value
            Columns("[COLOR=#ff0000]T:T[/COLOR]").Delete
            Range("[COLOR=#ff0000]T1[/COLOR]").Value = Temp
            Rng.Offset(, [COLOR=#ff0000]16[/COLOR]).SpecialCells(xlCellTypeBlanks).EntireRow.Delete


'START: Error MSG'
ErrorMSG:
    MsgBox "Svc Cols already transposed!"
'END: Error MSG'


End With
    MsgBox "Pls process to step 2"
Else
    MsgBox "MACRO aborted!" & vbNewLine & "Pls ensure Col U is empty."
End If
End Sub
 
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
475
sijpie
sijpie
O
  • Question
Moving data from a single column to get more row values to work with
2
Replies
11
Views
508
Peter_SSs
Peter_SSs
D
  • Question
Create Header Row From Data & Place Column Data Across 4 Columns
Replies
0
Views
416
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,388
Messages
6,119,226
Members
448,878
Latest member
Da9l87

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