Format using Macro

Solved/Closed
Rahul - Jun 25, 2010 at 03:20 AM
 harry - Mar 29, 2011 at 10:50 AM
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

venkat1926
Posts
1864
Registration date
Sunday June 14, 2009
Status
Contributor
Last seen
August 7, 2021
810
Jun 25, 2010 at 05:57 AM
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
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]
0
didnt understand
0
I am sorry but i got some and not full
0
i got it. Thanks a lot.
0
venkat1926
Posts
1864
Registration date
Sunday June 14, 2009
Status
Contributor
Last seen
August 7, 2021
810
Jun 25, 2010 at 10:25 PM
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
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.
0
Or else i will sample data to you. How i want the output. Is it fine?
0
where we have to type dim and all
0
venkat1926
Posts
1864
Registration date
Sunday June 14, 2009
Status
Contributor
Last seen
August 7, 2021
810
Jun 26, 2010 at 01:53 AM
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
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.
0
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.
0
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.
0
Hi

Sample data i have saved in below path

http://www.editgrid.com/user/kiranindia1986/Sample_Data
0
venkat1926
Posts
1864
Registration date
Sunday June 14, 2009
Status
Contributor
Last seen
August 7, 2021
810
Jun 26, 2010 at 06:53 AM
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 
0
You are awesome man. This is the output i expected.

Thanks Venkat, Thanks alot.
0