Macro required

Shweta

Well-known Member
Joined
Jun 5, 2011
Messages
514
Hi All,

I need a macro to change the format of a data.

NAME01-04-1302-04-1303-04-13
A15910
B24716
C223034
D452449
E50346
F372338
G483243
H334550
I11312
J2822

<colgroup><col width="64" span="4" style="width: 48pt; text-align: center;"> </colgroup><tbody>
</tbody>

Data is given in the above format and I need to arrange the data in below format. Data is for a month so it is difficult to do it manually.

DATENAMENUMBERS
01-04-13A15
01-04-13B2
01-04-13C22
01-04-13D45
01-04-13E50
01-04-13F37
01-04-13G48
01-04-13H33
01-04-13I11
01-04-13J2
02-04-13A9
02-04-13B47
02-04-13C30
02-04-13D24
02-04-13E34
02-04-13F23
02-04-13G32
02-04-13H45
02-04-13I3
02-04-13J8
03-04-13A10
03-04-13B16
03-04-13C34
03-04-13D49
03-04-13E6
03-04-13F38
03-04-13G43
03-04-13H50
03-04-13I12
03-04-13J22

<colgroup><col width="64" span="3" style="width: 48pt; text-align: center;"> </colgroup><tbody>
</tbody>

Please help me out with a macro.

Thanks in advance!

Regards,
Shweta
 

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.
This Macro assumes the following:

The initial table you have shown starts in A1 if this is not the case let me know.

Run the macro on a copy of the worksheet first.

Code:
Nextrow = 2
    Columns.Range("A:D").Insert
    Cells(1, 1).Value = "Date"
    Cells(1, 2).Value = "Name"
    Cells(1, 3).Value = "Numbers"
    For i = 6 To 40
        If Cells(1, i).Value <> "" Then
            Cells(Nextrow, 1).Resize(10) = Cells(1, i).Value
            Cells(2, 5).Resize(10).Copy Cells(Nextrow, 2)
            Cells(2, i).Resize(10).Copy Cells(Nextrow, 3)
        End If
        Nextrow = Nextrow + 10
    Next i
    Columns("A").AutoFit
End Sub
 
Upvote 0
This Macro assumes the following:
The initial table you have shown starts in A1
in this macro one new Sheet name with RESULT Generated Auto and your data will be move to that sheet before run pls make copy your file

Code:
Sub GetReArrange()
Application.ScreenUpdating = False
Sheets.Add.Name = "Result"
ActiveSheet.Next.Select
Do Until Range("B1").Value = ""
Range("B1").EntireColumn.Insert
Range("B1").Select
ActiveCell.Value = ActiveCell.Offset(0, 1).Value
Range("A1").End(xlDown).Offset(0, 1).Select
Range(Selection, Selection.End(xlUp)).FillDown
Range("A1", Range("C" & Rows.Count).End(xlUp)).Copy Sheets("Result").Range("A" & Rows.Count).End(xlUp).Offset(1, 0)
Range("B:C").EntireColumn.Delete
Loop
Sheets("Result").Select
Range("A1").EntireRow.Delete
Range("A2").Select
Do Until ActiveCell.Value = ""
If ActiveCell.Value = "NAME" Or ActiveCell.Value = "Name" Then ActiveCell.EntireRow.Delete
ActiveCell.Offset(1, 0).Select
Loop
Range("A1").Select
Columns("B:B").Cut
Columns("A:A").Insert Shift:=xlToRight
Range("A1").Value = "DATE"
Range("C1").Value = "Numbers"
Application.ScreenUpdating = True
End Sub
 
Last edited:
Upvote 0
Just realized whole code not copied over

Code:
Sub ArrangeAll()
Dim Nextrow As Long
Dim i As Long
Nextrow = 2
    Columns.Range("A:D").Insert
    Cells(1, 1).Value = "Date"
    Cells(1, 2).Value = "Name"
    Cells(1, 3).Value = "Numbers"
    For i = 6 To 40
        If Cells(1, i).Value <> "" Then
            Cells(Nextrow, 1).Resize(10) = Cells(1, i).Value
            Cells(2, 5).Resize(10).Copy Cells(Nextrow, 2)
            Cells(2, i).Resize(10).Copy Cells(Nextrow, 3)
        End If
        Nextrow = Nextrow + 10
    Next i
    Columns("A").AutoFit
End Sub
 
Upvote 0

Forum statistics

Threads
1,213,549
Messages
6,114,264
Members
448,558
Latest member
aivin

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