Format using Macro Solved/Closed

Question

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.

venkat1926 · Answer

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

venkat1926 · Answer

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

venkat1926 · Answer

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

venkat1926 · Answer

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

Format using Macro

4 responses

Similar discussions

Subscribe To Our Newsletter!