• Hi All

    Please note that at the Chandoo.org Forums there is Zero Tolerance to Spam

    Post Spam and you Will Be Deleted as a User

    Hui...

  • When starting a new post, to receive a quicker and more targeted answer, Please include a sample file in the initial post.

Split unique values add the header to the unique value.

sanju

New Member
Hello All,

I want to split the unique values in column "A".

1) All header values that have the same value in column "A".
2) Add a few extra rows before the start and after the end from unique values.
3) If the sequence of unique number in column "A" is missing, add it and fill in the details in between the unique value.

I really appreciate any help.
 

Attachments

p45cal

Well-Known Member
A really quick way to get this data sorted (almost) as you like is with a pivot table:
76520

I don't understand the logic behind what seem to be including the last of the previous group and the first of the next group, both in missing unique numbers and in successive groups. Could you expand on that please?
Do you really only have Excel 2003? This would not be straightforward to code vba for (but perfectly possible). Formulae would be extraordinarily complex.
If you have a more recent version of Excel (preferably at least Excel 2016), it should be fairly easy with Power Query (aka Get & Transform Data).
 
Last edited:

sanju

New Member
Thank you for the replay,
I have added some comments in excel please see it you will understand and also added VBA code which also added extra row.
But in this vba code it missing the sequence number in the unique value so it needs to be added.
I am currently using Excel 2007.
 

Attachments

Last edited:

Marc L

Excel Ninja
Hi, according to your initial post a VBA demonstration :​
Code:
Sub Demo1()
    Dim R&, S$, N&, Rf As Range, P&, L&
        R = 1
        Sheet2.UsedRange.Clear
        Application.ScreenUpdating = False
    With Sheet1.[A1].CurrentRegion.Rows
        With .Range("A2"):  S = .Text: .Value2 = "SL":  End With
       .Item("3:" & .Count).Sort .Cells(3, 1), 1, Header:=2
    For N = .Range("A3").Value2 To .Cells(.Count, 1).Value2
     With Sheet2.Cells(R, 1).Resize(, .Columns.Count)
       .Cells(1).Value2 = N
       .HorizontalAlignment = 7
       .VerticalAlignment = xlCenter
       .Font.Bold = True
     End With
       .Item(2).Copy Sheet2.Cells(R + 1, 1)
        Set Rf = .Columns(1).Find(N, , , 1)
    If Rf Is Nothing Then
       .Item(P).Resize(2).Copy Sheet2.Cells(R + 2, 1)
    Else
        P = .Columns(1).FindPrevious().Row
       .Item(Rf.Row + (R > 1) & ":" & P + 1).Copy Sheet2.Cells(R + 2, 1)
    End If
        L = Sheet2.[A1].End(xlDown).Row
        Sheet2.Range("A" & R + 2 & ":A" & L).Value2 = Evaluate("ROW(1:" & L - R - 1 & ")")
        R = L + 1
    Next
       .Range("A2").Value2 = S
    End With
        Application.ScreenUpdating = True
        Set Rf = Nothing
End Sub
Do you like it ? So thanks to click on bottom right Like !​
 

Marc L

Excel Ninja
As a reminder the correct explanation and attachment must be in the initial post …​
According to post #3 :​
Code:
Sub Demo2()
    Dim R&, S$, M&, N&, F&, Ar As Areas, A&, L&, C&, P&
        R = 1
        Sheet2.UsedRange.Clear
        Application.ScreenUpdating = False
    With Sheet1.[A1].CurrentRegion.Rows
        With .Range("A2"):  S = .Text:  .Value2 = "SL":  End With
        M = Application.Max(.Columns(1))
    For N = Application.Min(.Columns(1)) To M
      With Sheet2.Cells(R, 1).Resize(, .Columns.Count)
       .Cells(1).Value2 = N
       .HorizontalAlignment = 7
       .VerticalAlignment = xlCenter
       .Font.Bold = True
      End With
        F = R + 1
        With .Item("2:" & .Count):  .AutoFilter 1, N:  Set Ar = .SpecialCells(12).Areas:  End With
       .AutoFilter
    For A = 1 To Ar.Count
        L = Ar(A).Rows(Ar(A).Rows.Count).Row
        C = Ar(A).Rows.Count - (A > 1) - (L > 2 And N < M)
       .Item(Ar(A).Row + (A > 1)).Resize(C).Copy Sheet2.Cells(R + 1, 1)
        R = R + C
    Next
        If R > F Then P = L Else .Item(P).Resize(2).Copy Sheet2.Cells(R + 1, 1): R = R + 2
        Sheet2.Range("A" & F + 1 & ":A" & R).Value2 = Evaluate("ROW(1:" & R - F & ")")
        R = R + 1
    Next
       .Range("A2").Value2 = S
    End With
        Application.ScreenUpdating = True
        Set Ar = Nothing
End Sub
You should Like it !​
 

YasserKhalil

Well-Known Member
Greate my tutor. But as for the unique values, I tried only 1 and 4 and 9 so I expected three sub-tables but I got unnecessary tables.
 

sanju

New Member
As a reminder the correct explanation and attachment must be in the initial post …​
According to post #3 :​
Code:
Sub Demo2()
    Dim R&, S$, M&, N&, F&, Ar As Areas, A&, L&, C&, P&
        R = 1
        Sheet2.UsedRange.Clear
        Application.ScreenUpdating = False
    With Sheet1.[A1].CurrentRegion.Rows
        With .Range("A2"):  S = .Text:  .Value2 = "SL":  End With
        M = Application.Max(.Columns(1))
    For N = Application.Min(.Columns(1)) To M
      With Sheet2.Cells(R, 1).Resize(, .Columns.Count)
       .Cells(1).Value2 = N
       .HorizontalAlignment = 7
       .VerticalAlignment = xlCenter
       .Font.Bold = True
      End With
        F = R + 1
        With .Item("2:" & .Count):  .AutoFilter 1, N:  Set Ar = .SpecialCells(12).Areas:  End With
       .AutoFilter
    For A = 1 To Ar.Count
        L = Ar(A).Rows(Ar(A).Rows.Count).Row
        C = Ar(A).Rows.Count - (A > 1) - (L > 2 And N < M)
       .Item(Ar(A).Row + (A > 1)).Resize(C).Copy Sheet2.Cells(R + 1, 1)
        R = R + C
    Next
        If R > F Then P = L Else .Item(P).Resize(2).Copy Sheet2.Cells(R + 1, 1): R = R + 2
        Sheet2.Range("A" & F + 1 & ":A" & R).Value2 = Evaluate("ROW(1:" & R - F & ")")
        R = R + 1
    Next
       .Range("A2").Value2 = S
    End With
        Application.ScreenUpdating = True
        Set Ar = Nothing
End Sub
You should Like it !​
Thank you very much! Works perfectly...:)
 

Marc L

Excel Ninja
My first demonstration is the easy logic way sorting the source values …​
But as for the unique values, I tried only 1 and 4 and 9 so I expected three sub-tables but I got unnecessary tables.
Hello Yasser !​
I do not understand your point as according to sanju last post it « works perfectly »​
as when a value is missing it must be added in the result with a couple of rows …​
 

sanju

New Member
The old code is working perfectly, At this moment I want only selected number details from unique value, I have made some small changes in your code so that it gives details of selected number but it does not give details of missing number. As an example, I entered the Number 5, but it is not showing this result.

Code:
Sub Demo2()
    Dim InputValue As String
        InputValue = InputBox("Enter your value!")
    Dim R&, S$, M&, N&, F&, Ar As Areas, A&, L&, C&, P&
        R = 1
        Sheet2.UsedRange.Clear
        Application.ScreenUpdating = False
    With Sheet1.[A1].CurrentRegion.Rows
        With .Range("A2"):  S = .Text:  .Value2 = "SL":  End With
        M = Application.Max(.Columns(1))
    For N = InputValue To InputValue
      With Sheet2.Cells(R, 1).Resize(, .Columns.Count)
       .Cells(1).Value2 = N
       .HorizontalAlignment = 7
       .VerticalAlignment = xlCenter
       .Font.Bold = True
      End With
        F = R + 1
        With .Item("2:" & .Count):  .AutoFilter 1, N:  Set Ar = .SpecialCells(12).Areas:  End With
       .AutoFilter
    For A = 1 To Ar.Count
        L = Ar(A).Rows(Ar(A).Rows.Count).Row
        C = Ar(A).Rows.Count - (A > 1) - (L > 2 And N < M)
       .Item(Ar(A).Row + (A > 1)).Resize(C).Copy Sheet2.Cells(R + 1, 1)
        R = R + C
    Next
        If R > F Then P = L Else .Item(P).Resize(2).Copy Sheet2.Cells(R + 1, 1): R = R + 2
        Sheet2.Range("A" & F + 1 & ":A" & R).Value2 = Evaluate("ROW(1:" & R - F & ")")
        R = R + 1
    Next
       .Range("A2").Value2 = S
    End With
        Application.ScreenUpdating = True
        Set Ar = Nothing
End Sub
 

Marc L

Excel Ninja
I entered the Number 5, but it is not showing this result.
'Cause you did not make the appropriate changes …​
Code:
Sub Demo3()
        Dim N&, M&, S$, V, Ar As Areas, R&, A&, C&, Rf As Range
    With Sheet1.[A1].CurrentRegion.Rows
        N = Application.Min(.Columns(1))
        M = Application.Max(.Columns(1))
        S = " The number must be between " & N & " & " & M & " !"
    Do
        V = InputBox(vbLf & V & vbLf & vbLf & " Which SL number ?")
        If V = "" Then Exit Sub Else If V < N Or V > M Then V = S: Beep
    Loop Until IsNumeric(V)
         Application.ScreenUpdating = False
    With Sheet2.[A1].Resize(, .Columns.Count)
        .CurrentRegion.Clear
        .Cells(1).Value2 = V
        .HorizontalAlignment = 7
        .VerticalAlignment = xlCenter
        .Font.Bold = True
    End With
        With .Item("2:" & .Count):  .AutoFilter 1, V:  Set Ar = .SpecialCells(12).Areas:  End With
       .AutoFilter
        R = 1
    For A = 1 To Ar.Count
        C = Ar(A).Rows.Count - (A > 1) - (Ar(A).Rows(Ar(A).Rows.Count).Row > 2 And V < M)
       .Item(Ar(A).Row + (A > 1)).Resize(C).Copy Sheet2.Cells(R + 1, 1)
        R = R + C
    Next
    If R = 2 Then
        For A = V - 1 To N Step -1
            Set Rf = .Columns(1).Find(A, , xlValues, 1, , 2)
         If Not Rf Is Nothing Then .Item(Rf.Row).Resize(2).Copy Sheet2.[A3]: R = 4: Set Rf = Nothing: Exit For
        Next
    End If
        Sheet2.[A2].Value2 = "SL"
        Sheet2.Range("A3:A" & R).Value2 = Evaluate("ROW(1:" & R - 2 & ")")
        Application.ScreenUpdating = True
        Set Ar = Nothing
    End With
End Sub
You may Like it !​
 

sanju

New Member
I am still learning about VBA code,
Thank you once again for the code.
 
Last edited by a moderator:
Top