Range of cells on one sheet, sorted, blanks removed and data put into a column on another.

[dethanb]

Good day to you all,

I'm trying to develop a formula in Microsoft Excel.


I have a range of cells on one Worksheet and I want to take that Range of Cells, remove any blank cells, and sort the range of cells into a column on a Second Sheet, same Workbook.


The First Worksheet is set up as follows:
The Worksheet is 34 columns wide
Column 1 is merged A through D
Column 2 is merged E through J
Column 3 is merged K through P
Column 4 is merged Q through V
Column 5 is merged W through AB
Column 6 is merged AC through AH


Row 20 and 21 have the names I need to gather and place on the second sheet.


The second Worksheet is setup as follows:
The Worksheet is 4 columns wide
Column C is where I'd like the sorted and blank cells removed starting on row 3.

 

[dethanb]

Where do you want to check for the font color? Do you mean if any of the names are in color other than black they should not be added?

Exactly. So, what I do on the OVERVIEW sheet is if a column isn't going to be used (the data therein), I implement a Conditional Format that change the color of the Values in the column to the same color as the background (in essence hiding the values). So, when the array is created, if I could do a quick check on the Font Color to omit that value if the color is other than black.

I would think it could be a simple statement, but I've been unsuccessful in my reading various posts.

I've tried to implement this code:

    If [AC9] = "" Then
        Sheets("OVERVIEW").Range("AC18:AH24").Value = ""
        Sheets("GROUP E").Visible = False
    Else
        Sheets("GROUP E").Visible = True
    End If

But I get a:
"Run-Time Error '28':
Out of stack space"

I've tried this as well:

    If [AC9] = "" Then
        Sheets("OVERVIEW").Range("AC18:AH24").ClearContents
        Sheets("GROUP E").Visible = False
    Else
        Sheets("GROUP E").Visible = True
    End If

And I obtain the same error, and then the sheet locks up and has to be closed via Task Manager. Since the data in those cells has to potential to be used again in the future, if I can do a quick check of the font color and omit it if not black, then the data would remain and not be used during this event.

 

[sijpie]

I do not understand at all what you are trying to do with the pieces of code you are showing. Anyway, the following code does the trick. Basically I have added an array to hold the font colour of the first row (Evaluator1) of the table in sheet Overview.
Then I check if the font colour is black (.Font.Color = 0) and if so copy the value to the output array

That is all that is required. I have highlighted in red the additional code

Option Explicit


Sub SetupStaffRoster()
    Dim wsSR As Worksheet, wsOV As Worksheet
    Dim vIn As Variant, vOut As Variant, vCol As Variant
    Dim lRi As Long, lRo As Long, lCi As Long, UB As Long
    Dim rF As Range
    Dim sName As String
    
    With ThisWorkbook
        Set wsSR = .Sheets("staffroster")
        Set wsOV = .Sheets("overview")
    End With
    
    'get the row number in case things shift
    With wsOV
        Set rF = .Range(.Columns(1), .Columns(4)).Find(what:="Evaluator 1:", MatchCase:=False)
    End With
    If rF Is Nothing Then
        MsgBox "Can't find heading 'Evaluator 1:' in Overview column A."
        Exit Sub
    End If
    'load evaluators and roleplayers (7 rows and 34 columns) into an array (A:AH)
    vIn = rF.Resize(7, 34).Value
    UB = UBound(vIn, 2)
    
    'Create output array, 25 rows x 2 columns
    ReDim vOut(1 To 25, 1 To 2)
    'Create array to hold font colours , 1 row and same number of columns as input array
    ReDim vCol(1 To 1, 1 To UB)
    'fill this array with the font colour of the first row
    For lCi = 5 To UB Step 6 'because of the merged cells, each 6th column to be checked
        vCol(1, lCi) = rF.Offset(0, lCi - 1).Font.Color
    Next lCi
    'now go through input array and gather the evaluators by row _
     If evaluator font color <> black then skip
    For lRi = 1 To 2
        For lCi = 5 To UB Step 6 'because of the merged cells, each 6th column to be checked
            sName = vIn(lRi, lCi)
            If Len(sName) And vCol(1, lCi) = 0 Then
                lRo = lRo + 1
                vOut(lRo, 1) = sName    'in 1st column of output array
            End If
        Next lCi
    Next lRi
    'now go through input array and gather the role players by row
    lRo = 0 'reset
    For lRi = 3 To 7
        For lCi = 5 To UB Step 6 'because of the merged cells, each 6th column to be checked
            sName = vIn(lRi, lCi)
            If Len(sName) And vCol(1, lCi) = 0 Then
                lRo = lRo + 1
                vOut(lRo, 2) = sName    'in 2nd column of output array
            End If
        Next lCi
    Next lRi
    
    'now dump the output to the Staffroster sheet
    wsSR.Range("C3").Resize(UBound(vOut, 1), UBound(vOut, 2)).Value = vOut
    
    Set wsSR = Nothing
    Set wsOV = Nothing
    Set rF = Nothing
End Sub

 

[dethanb]

I do not understand at all what you are trying to do with the pieces of code you are showing.

Sorry, I was just showing other methods I had tried to get rid of the values. Thank you, and I'll give it a try.

 

[dethanb]

So, I've been working with this on and off again today making small changes trying to find the error without bothering you again.

I've ran it several times and it still puts the values that have changed color in the Roster sheet.

The way the sheet is set up, if the Column Header, let's say "E" (AC9:AH9) is deleted, it does a conditional format on the rest of the column changing the font color to the background color (Black to Light Green). Also, I've added a an extra column between Evaluators and Role Players. I was able to figure out how to move the second output column of your script over to the third column, but it doesn't work with the new version your provided me.

Once again, I look to you for a fix. Thank you in advance.

Here is a link to the actual Excel Workbook if needed

 

[sijpie]

Ah, the issue was that you use conditional formatting. And then the normal Range.Font.Color does not work. You need to use the Range.DisplayFormat.Font.Color to get the actual displayed colour. (This property is only available since Excel 2010.)

I have modified the code below also to the actual sheet name for the output (Roster) and the location for the dump (D3:G27)

Option Explicit

Sub SetupStaffRoster()
    Dim wsSR As Worksheet, wsOV As Worksheet
    Dim vIn As Variant, vOut As Variant, vCol As Variant
    Dim lRi As Long, lRo As Long, lCi As Long, UB As Long
    Dim rF As Range
    Dim sName As String
   
    With ThisWorkbook
        Set wsSR = .Sheets("roster")
        Set wsOV = .Sheets("overview")
    End With
   
    'get the row number in case things shift
    With wsOV
        Set rF = .Range(.Columns(1), .Columns(4)).Find(what:="Evaluator 1:", MatchCase:=False)
    End With
    If rF Is Nothing Then
        MsgBox "Can't find heading 'Evaluator 1:' in Overview column A."
        Exit Sub
    End If
    'load evaluators and roleplayers (7 rows and 34 columns) into an array (A:AH)
    vIn = rF.Resize(7, 34).Value
    UB = UBound(vIn, 2)
   
    'Create output array, 25 rows x 2 columns
    ReDim vOut(1 To 25, 1 To 4)
    'Create array to hold font colours , 1 row and same number of columns as input array
    ReDim vCol(1 To 1, 1 To UB)
    'fill this array with the font colour of the first row
    For lCi = 5 To UB Step 1 'because of the merged cells, each 6th column to be checked
        ' because these cells are using conditional formatting you have to use _
          the .DisplayFormat property of the cell
        vCol(1, lCi) = rF.Offset(0, lCi - 1).DisplayFormat.Font.Color
    Next lCi
    'now go through input array and gather the evaluators by row _
     If evaluator font color <> black then skip
    For lRi = 1 To 2
        For lCi = 5 To UB Step 6 'because of the merged cells, each 6th column to be checked
            sName = vIn(lRi, lCi)
            If Len(sName) And vCol(1, lCi) = 0 Then
                lRo = lRo + 1
                vOut(lRo, 1) = sName    'in 1st column of output array
            End If
        Next lCi
    Next lRi
    'now go through input array and gather the role players by row
    lRo = 0 'reset
    For lRi = 3 To 7
        For lCi = 5 To UB Step 6 'because of the merged cells, each 6th column to be checked
            sName = vIn(lRi, lCi)
            If Len(sName) And vCol(1, lCi) = 0 Then
                lRo = lRo + 1
                vOut(lRo, 3) = sName    'in 2nd column of output array
            End If
        Next lCi
    Next lRi
   
    'now dump the output to the Staffroster sheet
    wsSR.Range("D3").Resize(UBound(vOut, 1), UBound(vOut, 2)).Value = vOut
   
    Set wsSR = Nothing
    Set wsOV = Nothing
    Set rF = Nothing
End Sub