Need a macro
Closed
gopi
-
Jul 2, 2010 at 12:08 AM
venkat1926 Posts 1863 Registration date Sunday June 14, 2009 Status Contributor Last seen August 7, 2021 - Jul 2, 2010 at 06:30 AM
venkat1926 Posts 1863 Registration date Sunday June 14, 2009 Status Contributor Last seen August 7, 2021 - Jul 2, 2010 at 06:30 AM
Related:
- Need a macro
- Spell number in excel without macro - Guide
- Macro excel download - Download - Spreadsheets
- Excel macro to create new sheet based on value in cells - Guide
- Run macro on opening workbook - Guide
- Excel vba assign macro to button programmatically - Guide
1 response
venkat1926
Posts
1863
Registration date
Sunday June 14, 2009
Status
Contributor
Last seen
August 7, 2021
811
Jul 2, 2010 at 06:30 AM
Jul 2, 2010 at 06:30 AM
the data is sheet 1 like this
INVOICE
On-2006-012
On-2006-013
Off-2007-014
Off-2007-011
Off-2007-012
Kn-2009-016
Kn-2009-012
On-2008-012
On-2007-016
Off-2008-014
Off-2008-012
Kn-2010-022
1. as you are messing up with dta <gras>COPY THIS DATA IN SHEET 3 FROM A1.</gras>
TO BE ON SAFE SIDE SAVE THE FILE SOMEWEHRE SO THAT IT CAN BE RETRIEVED.
2. RUN THE MACRO "TEST"
the second macro "undo" is to undo the result of the macro "test"
may be the macro is pedestrian. but it works.
==================
Sub test()
Dim r As Range, j As Integer, k As Integer
Set r = Range(Range("A1"), Range("A1").End(xlDown))
r.TextToColumns Destination:=Range("A1"), DataType:=xlDelimited, _
ConsecutiveDelimiter:=False, other:=True, otherchar:= _
"-"
Set r = Range("A1").CurrentRegion
'MsgBox r.Address
r.Sort key1:=Range("a1"), key2:=Range("B1"), order2:=xlAscending, key3:=Range("c1"), order3:=xlAscending
j = Cells(Rows.Count, 1).End(xlUp).Row
For k = j To 2 Step -1
If Cells(k, 1) <> Cells(k - 1, 1) Then
Cells(k, 1).EntireRow.Insert
End If
Next k
j = Cells(Rows.Count, 1).End(xlUp).Row
For k = j To 2 Step -1
If Cells(k - 1, 2) <> Cells(k, 2) Then
Cells(k, 2).EntireRow.Insert
End If
Next k
j = Cells(Rows.Count, 1).End(xlUp).Row
For k = j To 2 Step -1
If Cells(k, 1) = "" And Cells(k - 1, 1) = "" Then
Cells(k, 1).EntireRow.Delete
End If
Next
j = Cells(Rows.Count, 1).End(xlUp).Row
For k = j To 2 Step -1
If Cells(k, 1) <> "" Then
Cells(k, 1) = Cells(k, 1) & "-" & Cells(k, 2) & "-" & Cells(k, 3)
End If
Next
Range("B1:c1").EntireColumn.Delete
Range("A1").EntireColumn.AutoFit
Range("A2").EntireRow.Delete
End Sub
=========================
YOUR COMMENTS PLEASE
Sub undo()
Worksheets("sheet1").Cells.Clear
Worksheets("sheet3").UsedRange.Copy Worksheets("sheet1").Range("A1")
End Sub
==============================
INVOICE
On-2006-012
On-2006-013
Off-2007-014
Off-2007-011
Off-2007-012
Kn-2009-016
Kn-2009-012
On-2008-012
On-2007-016
Off-2008-014
Off-2008-012
Kn-2010-022
1. as you are messing up with dta <gras>COPY THIS DATA IN SHEET 3 FROM A1.</gras>
TO BE ON SAFE SIDE SAVE THE FILE SOMEWEHRE SO THAT IT CAN BE RETRIEVED.
2. RUN THE MACRO "TEST"
the second macro "undo" is to undo the result of the macro "test"
may be the macro is pedestrian. but it works.
==================
Sub test()
Dim r As Range, j As Integer, k As Integer
Set r = Range(Range("A1"), Range("A1").End(xlDown))
r.TextToColumns Destination:=Range("A1"), DataType:=xlDelimited, _
ConsecutiveDelimiter:=False, other:=True, otherchar:= _
"-"
Set r = Range("A1").CurrentRegion
'MsgBox r.Address
r.Sort key1:=Range("a1"), key2:=Range("B1"), order2:=xlAscending, key3:=Range("c1"), order3:=xlAscending
j = Cells(Rows.Count, 1).End(xlUp).Row
For k = j To 2 Step -1
If Cells(k, 1) <> Cells(k - 1, 1) Then
Cells(k, 1).EntireRow.Insert
End If
Next k
j = Cells(Rows.Count, 1).End(xlUp).Row
For k = j To 2 Step -1
If Cells(k - 1, 2) <> Cells(k, 2) Then
Cells(k, 2).EntireRow.Insert
End If
Next k
j = Cells(Rows.Count, 1).End(xlUp).Row
For k = j To 2 Step -1
If Cells(k, 1) = "" And Cells(k - 1, 1) = "" Then
Cells(k, 1).EntireRow.Delete
End If
Next
j = Cells(Rows.Count, 1).End(xlUp).Row
For k = j To 2 Step -1
If Cells(k, 1) <> "" Then
Cells(k, 1) = Cells(k, 1) & "-" & Cells(k, 2) & "-" & Cells(k, 3)
End If
Next
Range("B1:c1").EntireColumn.Delete
Range("A1").EntireColumn.AutoFit
Range("A2").EntireRow.Delete
End Sub
=========================
YOUR COMMENTS PLEASE
Sub undo()
Worksheets("sheet1").Cells.Clear
Worksheets("sheet3").UsedRange.Copy Worksheets("sheet1").Range("A1")
End Sub
==============================
