Format using Macro [Solved/Closed]

Report
-
 harry -
Hi

I have some data in sheet1.

Eg: Column A Column B Column C Column D
1 2 3 4
5 6 7 8
9 10 11 12
13 14 15 16

Now i wanted to display in folwing format:

Column A Column B
1 2
5 6
9 10
13 14

1 3
5 7
9 11
13 15

1 4
5 8
9 12
13 16

Please assist me.

4 replies

Posts
1862
Registration date
Sunday June 14, 2009
Status
Contributor
Last seen
July 30, 2015
791
the data is in active sheet from A1 to D4

1 2 3 4
5 6 7 8
9 10 11 12
13 14 15 16





keep the sheet as active sheet and try this macro

Sub test() 
Dim rc As Range, cc As Range, rr As Range, cr 
Dim r1 As Range 
Set rc = Range(Range("B1"), Range("B1").End(xlToRight)) 
Set rr = Range(Range("A1"), Range("A1").End(xlDown)) 
Set r1 = rr.End(xlDown).Offset(1, 0) 
Range(r1, Cells(Rows.Count, 1)).EntireRow.Delete 

For Each cc In rc 

rr.Copy 
Cells(Rows.Count, "A").End(xlUp).Offset(3, 0).PasteSpecial 
 Range(Cells(cc.Row, cc.Column), Cells(cc.Row, cc.Column).End(xlDown)).Copy 
 Cells(Rows.Count, "B").End(xlUp).Offset(3, 0).PasteSpecial 
Next cc 
End Sub 


your comments please
1
Thank you

A few words of thanks would be greatly appreciated. Add comment

CCM 2942 users have said thank you to us this month

Hi Venkat

Its Working, but small changes like, i want header only at the begining and differences i wanted to show in one line gap.( Not 2). [Actually First line is the header]
didnt understand
I am sorry but i got some and not full
i got it. Thanks a lot.
Posts
1862
Registration date
Sunday June 14, 2009
Status
Contributor
Last seen
July 30, 2015
791
quote
Actually First line is the header]
unquoe
not clar.there is no hading in your data. anyhow I modified the macro. if thisisnto what yuu want send result as you want.

Sub test()
Dim rc As Range, cc As Range, rr As Range
Dim r1 As Range, x, r2 As Range
Set rc = Range(Range("B1"), Range("B1").End(xlToRight))
Set rr = Range(Range("A1"), Range("A1").End(xlDown))
Set r1 = rr.End(xlDown).Offset(1, 0)
Range(r1, Cells(Rows.Count, 1)).EntireRow.Delete

For Each cc In rc

rr.Copy
Cells(Rows.Count, "A").End(xlUp).Offset(2, 0).PasteSpecial
 Range(Cells(cc.Row, cc.Column), Cells(cc.Row, cc.Column).End(xlDown)).Copy
 Cells(Rows.Count, "B").End(xlUp).Offset(2, 0).PasteSpecial
Next cc
x = Array("hdng1", "hdng2")
Range("a1").End(xlDown).Offset(1, 0).EntireRow.Insert
Set r2 = Range("a1").End(xlDown).Offset(2, 0)
Set r2 = Range(r2, r2.Offset(0, 1))
r2 = x

End Sub
1
Thank you

A few words of thanks would be greatly appreciated. Add comment

CCM 2942 users have said thank you to us this month

sorry Venkat,

I know my words made you full confusion.

Actulaly my first row itself is a heading, my data starts from 2nd row.

Why the space between column becuase i want to calculate the total of first group, total of second group.....etc(i.e Total column B)

Please looking for yuor support.
Or else i will sample data to you. How i want the output. Is it fine?
where we have to type dim and all
Posts
1862
Registration date
Sunday June 14, 2009
Status
Contributor
Last seen
July 30, 2015
791
you have given column headings as column A,column B,etc. even though you can do this theoreitically it is not conventionally done. that is why the confusion. Normally it will be taken NOTas column headings but only as the data is in those particualr columns . according to you your main data from A1 to D5 will be

Column A Column B Column C Column D
1 2 3 4
5 6 7 8
9 10 11 12
13 14 15 16

row 1 contains headings
row 2 to ro 5 cotains data.


of course the macro needed slight modification. the modified macro isgiven below


Sub test()
Dim rc As Range, cc As Range, rr As Range
Dim r1 As Range, x, r2 As Range
Set rc = Range(Range("B2"), Range("B2").End(xlToRight))
Set rr = Range(Range("A2"), Range("A2").End(xlDown))
Set r1 = rr.End(xlDown).Offset(1, 0)
Range(r1, Cells(Rows.Count, 1)).EntireRow.Delete

For Each cc In rc

rr.Copy
Cells(Rows.Count, "A").End(xlUp).Offset(2, 0).PasteSpecial
Range(Cells(cc.Row, cc.Column), Cells(cc.Row, cc.Column).End(xlDown)).Copy
Cells(Rows.Count, "B").End(xlUp).Offset(2, 0).PasteSpecial
Next cc
x = Array("colmn A", "column B")
Range("a1").End(xlDown).Offset(1, 0).EntireRow.Insert
Set r2 = Range("a1").End(xlDown).Offset(2, 0)
Set r2 = Range(r2, r2.Offset(0, 1))
r2 = x

End Sub
1
Thank you

A few words of thanks would be greatly appreciated. Add comment

CCM 2942 users have said thank you to us this month

Its working fine. I have to add some more changes in the same excel.

Please advice whether i have to post a new thread or i can continue here only.
Hi

i want small modification.

1. I want the heading name to all line item in Column B.
2. I want the total of each group , that has to display in at the end of each group.

Please assist.
Hi

i want small modification.

1. I want the heading name to all line item in Column B.
2. I want the total of each group , that has to display in at the end of each group.

Please assist.
Hi

Sample data i have saved in below path

http://www.editgrid.com/user/kiranindia1986/Sample_Data
Posts
1862
Registration date
Sunday June 14, 2009
Status
Contributor
Last seen
July 30, 2015
791
is this a different project . It looks very simialr to the old one but more complicated. Had yougiven this data I could have given you the macro without working on the old configuration.

anyhow I am sending the file back to you.; the name of the file is "rahul.cls"
you can download this file from tis url

http://www.speedyshare.com/files/23138230/rahul.xls

the macro "finalmacro" has already been run. see sheet2 for results

IGNORE SHEET3. TAHT IS FOR MY EXPERIEMNTS. YOU CAN EVEN DELTETE SHEET3.

if you want to retest

1. run undo( which undoes the result of the mcro "finalmacro"
2.run "finalmacro" ONLY.

bUT ALL THE MACROS SHOULD BE PARKED IN THE MODULE IN THE VBEDITOR.
They are already there.

for comfpeltio'ns sake I am giving the macros below

Dim rdata As Range, rcol As Range, ccol As Range 
Dim j As Integer, k As Integer 
Dim x, m As Integer, r As Range 
Sub finalmacro() 
Worksheets("sheet1").Activate 
Set rdata = Range("a1").CurrentRegion 
j = Range("a1").End(xlDown).Row 
'msgbox rdata.Address 
Set rcol = Range(Range("B1"), Range("B1").End(xlToRight)) 
For Each ccol In rcol 
k = Cells(Rows.Count, "a").End(xlUp).Offset(2, 0).Row 
'msgbox Range(Range("a1"), Cells(j, "A")).Address 

Range(Range("a2"), Cells(j, "A")).Copy 
Cells(k, "A").PasteSpecial 
Range(ccol.Offset(1, 0), Cells(j, ccol.Column)).Copy 
Cells(k, "c").PasteSpecial 
'msgbox k 
'msgbox j 
Range(Cells(k, "B"), Cells(k + j - 2, "B")).FormulaArray = ccol.Value 
Next ccol 
headings 
movetosheet2 
cosmetics 
End Sub


Sub headings() 
Worksheets("sheet2").Cells.Clear 
Worksheets("sheet1").Activate 
j = Range("a1").End(xlDown).Offset(2, 0).Row 
'msgbox j 
x = Array("user", "activity", "time taken") 
Cells(j, "A").EntireRow.Insert 
Range(Cells(j, "A"), Cells(j, "c")) = x 
End Sub


Sub movetosheet2() 
Worksheets("sheet1").Activate 
j = Range("a1").End(xlDown).Offset(2, 0).Row 
k = Cells(Rows.Count, "A").End(xlUp).Row 
'msgbox j 
'msgbox k 
Range(Cells(j, "a"), Cells(k, "c")).Cut 
Worksheets("sheet2").Activate 
Range("a1").Select 
ActiveSheet.Paste 
End Sub 


Sub cosmetics() 
Worksheets("sheet2").Activate 
j = 1 
k = Cells(Rows.Count, "A").End(xlUp).Row 
For m = k + 1 To j Step -1 
If Cells(m, "c") = "" And Cells(m, "A") = "" Then 
Cells(m, "b") = "total" 
Set r = Range(Cells(m - 1, "c"), Cells(m - 4, "c")) 
Cells(m, "c") = WorksheetFunction.Sum(r) 
Cells(m, "C").NumberFormat = "h:mm:ss;@" 
End If 
Next m 
For m = k To j Step -1 

If Cells(m, "c") = "" And Cells(m, "a") <> "" Then 
Cells(m, "c").EntireRow.Delete 
End If 
Next m 

End Sub


Sub undo() 
Worksheets("sheet2").Cells.Clear 
End Sub 
You are awesome man. This is the output i expected.

Thanks Venkat, Thanks alot.