Help to create the macros to Data Arrangment automatically.

[sampath]

Dear Friend,


I need to arrange the Set of data's which i give in below mentioned link.


http://www.fileconvoy.com/dfl.php?id=g2053754e7ed07f4b999271653a2a5a46cf534f112


Needed things,


In this Set of Data's

1, If two numbers ( space between these numbers ) are availabe in the same cell, one can move to last cell.

2, Duplicate numbers need to delete automatically.

3, Delete N°


Please help me to do for my project.


Thank with regards,

SAMPATH.S

 

[SirJB7]

Hi, sampath!


First define in your worksheet 2 named ranges for each orange area: LabelInputList and LabelOutputList.

Then place the below code in a new module, then run procedure X.


-----

[pre]

Option Explicit

Sub X()
' constants
Const ksWSI = "Sheet1"
Const ksInput = "LabelInputList"
Const ksWSO = "Sheet1"
Const ksOutput = "LabelOutputList"
Const ksSeparator = "-"
Const ksExclude = "N°"
' declarations
Dim rngI As Range, rngO As Range
Dim I As Integer, J As Integer, K As Integer, A As String, bOk As Boolean
Dim sOutput As String, iAll As Integer, sArrayAux() As String, sArrayAll() As String
' start
Set rngI = Worksheets(ksWSI).Range(ksInput)
Set rngO = Worksheets(ksWSO).Range(ksOutput)
' process
With Worksheets(ksWSI)
For J = 1 To rngI.Columns.Count
' build list
iAll = 0
I = 1
sOutput = ""
ReDim sArrayAll(0)
Do Until .Cells(rngI.Row + I, rngI.Column + J - 1).Value = ""
A = .Cells(rngI.Row + I, rngI.Column + J - 1).Value
sArrayAux = Split(A)
For K = 0 To UBound(sArrayAux)
iAll = iAll + 1
ReDim Preserve sArrayAll(UBound(sArrayAll) + 1)
sArrayAll(iAll) = sArrayAux(K)
Next K
I = I + 1
Loop
' sort list
For I = 1 To iAll - 1
For K = I + 1 To iAll
bOk = False
If Val(sArrayAll(I)) > 0 And Val(sArrayAll(K)) > 0 Then
If Val(sArrayAll(I)) > Val(sArrayAll(K)) Then
bOk = True
Else
bOk = False
End If
Else
If sArrayAll(I) > sArrayAll(K) Then
bOk = True
Else
bOk = False
End If
End If
If bOk Then
A = sArrayAll(I)
sArrayAll(I) = sArrayAll(K)
sArrayAll(K) = A
End If
Next K
Next I
' final list
sOutput = ""
K = 0
For I = 1 To iAll
bOk = False
If sArrayAll(I) <> ksExclude Then
If I = 1 Then
bOk = True
Else
If sArrayAll(I) <> sArrayAll(I - 1) Then bOk = True
End If
End If
If bOk Then
K = K + 1
If K <> 1 Then sOutput = sOutput & ksSeparator
sOutput = sOutput & sArrayAll(I)
End If
Next I
.Cells(rngO.Row + J - 1, rngO.Column + 1).Value = sOutput
Next J
End With
' end
Set rngO = Nothing
Set rngI = Nothing
End Sub

[/pre]
-----


Just advise if any issue.


Regards!