Need a macro
Closed
gopi
-
2 Jul 2010 à 00:08
venkat1926 Posts 1863 Registration date Sunday 14 June 2009 Status Contributor Last seen 7 August 2021 - 2 Jul 2010 à 06:30
venkat1926 Posts 1863 Registration date Sunday 14 June 2009 Status Contributor Last seen 7 August 2021 - 2 Jul 2010 à 06:30
Related:
- Need a macro
- How to run a macro in excel - Guide
- Run Macros in Excel: online, shortcuts, VBA - Guide
- How to copy macro from one workbook to another - Guide
- Macro for number to words in excel - Guide
- Macro antena apk - Download - Gaming tools
1 response
venkat1926
Posts
1863
Registration date
Sunday 14 June 2009
Status
Contributor
Last seen
7 August 2021
811
2 Jul 2010 à 06:30
2 Jul 2010 à 06:30
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
==============================
