• 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.

extract unique values in one column and use as Sub Headers at each line break

2

2011gerry007

Member
Hi,

And thanks for taking the time to look :)

I have a spreadsheet with one column... (F) that contains various different session times for each person for any given day. So for the first session I may have 20 peoples names attending on each row with the session time, (I already have the vba to insert 2X blank lines at each session value/time change).

What I would like to be able to do is get rid of all the 20 duplicate times that are beside each name/Record and just have as one instance and all the people name for that session below that session time

So basically strip the column(F) and have sub headers each session which can be up to 40 in one day, and that way I can delete the column (F) of the values

vba wise . Does anyone know the best way on how I could go about getting unique values from one column (aside from the header) and using some sort of loop ...say distinct values and put each session as a sub header at each line break?

apologies but can't see where an upload icon is for my sample sheet .

What i have .....Below...
Session Times
08:30 - 11:30
08:30 - 11:30
08:30 - 11:30
08:30 - 11:30
08:30 - 11:30
08:30 - 11:30
08:30 - 11:30
08:30 - 11:30


08:45 - 09:45
08:45 - 09:45
08:45 - 09:45


10:00 - 11:00
10:00 - 11:00


11:00 -12:00
11:00 -12:00
11:00 -12:00


12:00 - 13:00
12:00 - 13:00
12:00 - 13:00
12:00 - 13:00
12:00 - 13:00
12:00 - 13:00
12:00 - 13:00
12:00 - 13:00
12:00 - 13:00
12:00 - 13:00
12:00 - 13:00
12:00 - 13:00
12:00 - 13:00
12:00 - 13:00
12:00 - 13:00
12:00 - 13:00
12:00 - 13:00
12:00 - 13:00
12:00 - 13:00

What i like

Session Times = 08:30 - 11:30

TmGone Name
9:52 PM John Gardener01
10:52 PM John Gardener02
11:52 PM John Gardener03
12:52 AM John Gardener04
1:52 AM John Gardener05
2:52 AM John Gardener06
3:52 AM John Gardener07
4:52 AM John Gardener08

Session Times = 08:45 - 09:45
9:20 AM Timmy Jones005
9:40 AM Timmy Jones006
9:42 AM Timmy Jones007


Session Times = 10:00 - 11:00
Fred West 05
Fred West 06


Session Times = 11:00 -12:00
Jimmy Smith01
Jimmy Smith02
Jimmy Smith03


Session Times =12:00 - 13:00
Tony. McCussack04
Tony. McCussack05
Tony. McCussack06
Tony. McCussack07
Tony. McCussack08
Tony. McCussack09
Tony. McCussack10
Tony. McCussack11
Tony. McCussack12
Tony. McCussack13
Tony. McCussack14
Tony. McCussack15
Tony. McCussack16
Tony. McCussack17
Tony. McCussack18
Tony. McCussack19
Tony. McCussack20
Tony. McCussack21
Tony. McCussack22
 
Last edited:
So that all said in english is:
Goto the first block in column and take the first cell value from column F and copy or store the value then move the line above and move 2X cells to the left and add the word "Session time = " & cell_value (possibly merging ,formatting bordering the 2X cells together) before pasting, then deleting the remaining duplicates moving onto the next session times (each block of sessions already has 2X blank rows inserted in between)
 
I think I almost have it, if anyone can help tidy this up, the only thing is it gets the session time above the wrong session, so I am lost on this part...Many thanks in advance if anyone out there is listening

The below Vba stops at each blank row as it steps through the For loop in Column F then when it finds a blank it it copies the specified offset value and pastes the value at another position then when finished looping deletes the column and shifts left.
Code: 
ublic Sub SelectFirstBlankCell()

    Dim sourceCol As Integer, rowCount As Integer, currentRow  As Integer
    Dim currentRowValue  As String

    sourceCol = 6  'column F has a value of 6
    rowCount = Cells(Rows.Count, sourceCol).End(xlUp).Row '' counts all rows including the blanks

    'for every row, find the first blank cell and select it
    For currentRow = 1 To rowCount
        currentRowValue = Cells(currentRow, sourceCol).Value
        If IsEmpty(currentRowValue) Or currentRowValue = "" Then
            
            Cells(currentRow, sourceCol).Offset(-1, 0).Select
            Cells(currentRow, sourceCol).Offset(-1, 0).Copy
            ActiveCell.Offset(1, -2).PasteSpecial ' Step down 1Row & 2left from current position
            ActiveCell.Offset(0, -1).Value = "Session-Times for above" ' but need it to be session times below
            MsgBox " Still to Merge Cells, Format, Border and Colour"
    
        End If
      
    Next
    MsgBox " finished ,now delete Column F "
    Stop
        ActiveSheet.Columns("F:F").Delete  ''''Shift:=xlToLeft
End Sub
 
upload sample sheet one is what I have so far and sheet 2 is what I'd like

Thanks guys and girls


▬▬▬▬▬▬▬▬▬ Mod edit : thread moved to appropriate forum !
​
 

Attachments

  • V1_Sample.zip
    21.5 KB · Views: 5
This should get you started:
Code: 
Sub blah()
'Sheets("As Is Report").Copy after:=Sheets(Sheets.Count)
Set Zones = Range(Range("F2"), Cells(Rows.Count, "F").End(xlUp)).SpecialCells(xlCellTypeConstants, 23).Areas
For Z = Zones.Count To 1 Step -1
  With Zones(Z)
  Rows(.Row).Insert
  .Cells(1).Offset(-1, -2).Value = "Session Time " & .Cells(1).Value
  With .Cells(1).Offset(-1, -2).Resize(, 2)
  .Offset(-1).EntireRow.Resize(2, 8).Interior.Color = xlNone
  .HorizontalAlignment = xlCenterAcrossSelection
  'more formatting here if you want.
  .BorderAround xlDouble
  .Interior.Color = 12566463
  End With
  End With
Next Z
Columns("F:F").Delete
End Sub
 
Last edited:
p45cal said:
This should get you started:
Code: 
Sub blah()
'Sheets("As Is Report").Copy after:=Sheets(Sheets.Count)
Set Zones = Range(Range("F2"), Cells(Rows.Count, "F").End(xlUp)).SpecialCells(xlCellTypeConstants, 23).Areas
For Z = Zones.Count To 1 Step -1
  With Zones(Z)
  Rows(.Row).Insert
  .Cells(1).Offset(-1, -2).Value = "Session Time " & .Cells(1).Value
  With .Cells(1).Offset(-1, -2).Resize(, 2)
  .Offset(-1).EntireRow.Resize(2, 8).Interior.Color = xlNone
  .HorizontalAlignment = xlCenterAcrossSelection
  'more formatting here if you want.
  .BorderAround xlDouble
  .Interior.Color = 12566463
  End With
  End With
Next Z
Columns("F:F").Delete
End Sub
Click to expand...

many thanks, and as always works a treat.

I had a rather long winded approach below, but I learned a few things on the way :)

Code: 
Public Sub SelectFirstBlankCellBB()
' this vba selects each blankkC row as it steps through the For loop in Column F
'then  when it finds a blank it it copies the specified offset value and pastes at another position then deletes F
   
    Dim outputText As String
        Dim Cell As Variant
            Dim sourceCol As Integer, rowCount As Integer, currentRow  As Integer
                Dim currentRowValue  As String
   
    Const delim = " "
        sourceCol = 6  'column F has a value of 6
          rowCount = Cells(Rows.Count, sourceCol).End(xlUp).Row '' counts all rows including the blanks

        'for every row, find the first blank cell in col F
    For currentRow = 2 To rowCount 'change interger "2" so  as to skip headers rows
                currentRowValue = Cells(currentRow, sourceCol).Value
        If IsEmpty(currentRowValue) Or currentRowValue = "" Then
            Stop
          Cells(currentRow, sourceCol).Offset(1, 0).Select
          Cells(currentRow, sourceCol).Offset(1, 0).Copy
          ActiveCell.Offset(-1, -2).PasteSpecial ' Step down 1Row & 2left from current position
          ActiveCell.Offset(0, -1).Value = "Session-Time = "
          Range(ActiveCell.Offset(0, -1), ActiveCell.Offset(0, 2)).Select 'offset sets the number of cells to merge
           
            '>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>

On Error Resume Next
outputText = ""
For Each Cell In Selection
    outputText = outputText & Cell.Value & delim 'starts looping till all selected cells are merged
Next Cell
With Selection
  .Clear
  .Cells(1).Value = outputText
  .Merge
  .HorizontalAlignment = xlCenter
  .VerticalAlignment = xlCenter
  .WrapText = True
End With

    Selection.Borders(xlInsideVertical).LineStyle = xlNone
    Selection.Borders(xlInsideHorizontal).LineStyle = xlNone

    With Selection
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlCenter
        .WrapText = True
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = True
    End With
   
    Selection.Borders(xlInsideVertical).LineStyle = xlNone
    Selection.Borders(xlInsideHorizontal).LineStyle = xlNone
    With Selection.Interior
        .Pattern = xlSolid
        .PatternColorIndex = xlAutomatic
        .ThemeColor = xlThemeColorDark1
        .TintAndShade = -0.14996795556505
        .PatternTintAndShade = 0
    End With
    With Selection.Font
        .Name = "Calibri"
        .Size = 16
        .Strikethrough = False
        .Superscript = False
        .Subscript = False
        .OutlineFont = False
        .Shadow = False
        .Underline = xlUnderlineStyleNone
        .ThemeColor = xlThemeColorLight1
        .TintAndShade = 0
        .ThemeFont = xlThemeFontMinor
    End With
    Selection.Borders(xlDiagonalDown).LineStyle = xlNone
    Selection.Borders(xlDiagonalUp).LineStyle = xlNone
    With Selection.Borders(xlEdgeLeft)
        .LineStyle = xlContinuous
        .ColorIndex = xlAutomatic
        .TintAndShade = 0
        .Weight = xlMedium
    End With
    With Selection.Borders(xlEdgeTop)
        .LineStyle = xlContinuous
        .ColorIndex = xlAutomatic
        .TintAndShade = 0
        .Weight = xlMedium
    End With
    With Selection.Borders(xlEdgeBottom)
        .LineStyle = xlContinuous
        .ColorIndex = xlAutomatic
        .TintAndShade = 0
        .Weight = xlMedium
    End With
    With Selection.Borders(xlEdgeRight)
        .LineStyle = xlContinuous
        .ColorIndex = xlAutomatic
        .TintAndShade = 0
        .Weight = xlMedium
    End With
 
    Selection.Borders(xlDiagonalDown).LineStyle = xlNone
    Selection.Borders(xlDiagonalUp).LineStyle = xlNone
    With Selection.Borders(xlEdgeLeft)
        .LineStyle = xlContinuous
        .ColorIndex = xlAutomatic
        .TintAndShade = 0
        .Weight = xlThick
    End With
    With Selection.Borders(xlEdgeTop)
        .LineStyle = xlContinuous
        .ColorIndex = xlAutomatic
        .TintAndShade = 0
        .Weight = xlThick
    End With
    With Selection.Borders(xlEdgeBottom)
        .LineStyle = xlContinuous
        .ColorIndex = xlAutomatic
        .TintAndShade = 0
        .Weight = xlThick
    End With
    With Selection.Borders(xlEdgeRight)
        .LineStyle = xlContinuous
        .ColorIndex = xlAutomatic
        .TintAndShade = 0
        .Weight = xlThick
    End With

        End If
       
    Next
        MsgBox " finished ,now delete Column F "
    Stop
        ActiveSheet.Columns("F:F").Delete  ''''Shift:=xlToLeft
End Sub
 
You must log in or register to reply here.
Back
Top