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.

 

[sijpie]

hi dethanb,

not totally clear what you want to do.

In cell C on Sheet 2 you want to get the 'sorted and cleanedup list' from Sheet1.
But you mention that Sheet1 is 6 columns, and sheet2 is 4 columns.
So:
Which (merged)columns need to be copied to Sheet2?
On which column is the sort going to be applied?

and:
What do you mean with "Row 20 and 21 have the names I need to gather and place on the second sheet"
need to be placed where? I thought you wanted the total columns to be copied?

please elaborate

 

[dethanb]

Good day to you sijpie,

Thanks for your inquiry to my problem. I've uploaded a couple of screen shots and an example file of what I'm looking for. I'll post the links here and hope they work.

In this Excel Workbook there are two sheets, Overview (Sheet 1) and Staff Roster (Sheet 2).

On the Overview Sheet rows 20 and 21 contain merged cells along with evaluator names in respective (merged) columns. Some have names in them depending on the activity being conducted, and others have blank entries. I would like to take these names, and put them on the Staff Roster (Sheet 2) worksheet into a single column, blanks removed, and sorted as in the example on that sheet.

I would prefer to be able to do this in a =FORMULA(), but can do it in VBA if need be. I can work with VBA as long as it's not overly convoluted.

Does this clear things up a bit? I appreciate any help.

----------------------------------------

Sheet 1 Screen Shot: https://www.dropbox.com/s/q2xxze9gnqqfxxa/Example 1.png?dl=0
Sheet 2 Screen Shot: https://www.dropbox.com/s/iviidx51eab1hc0/Example 2.png?dl=0
Example Excel Workbook: https://www.dropbox.com/s/jcn7hvrbo2q9bsi/Example.xlsm?dl=0

 

[dethanb]

So,

I've been scouring the internet looking for bits of code that I can compile into a usable macro to do what I was wanting... So far, this is what I've come up with. Can I possible get some help from what I have here? This is using a test sheet that I did quickly and can manipulate as I test the code.

Private Sub Worksheet_Change(ByVal Target As Range)
On Error Resume Next

' --- I just clear it to keeps things clean in my mind during testing.
Sheets("Sheet2").Range("A1:A20").Clear

' --- First row of data from Sheet 1
Sheets("Sheet1").Range("A1:G1").Copy

' --- Pasted to Sheet 2 Column A
Sheets("Sheet2").Range("A1").PasteSpecial SkipBlanks:=True, Transpose:=True

' --- Second row of data from Sheet 1
Sheets("Sheet1").Range("A2:G2").Copy

' --- Pasted to Sheet 2 Column A farther down that what I need. I'd like to just start where the last cell entry was.
Sheets("Sheet2").Range("A10").PasteSpecial SkipBlanks:=True, Transpose:=True

' --- I sort it here to put the blank cells on the bottom and the data I need on top. Is there a way to get rid of the blanks
Sheets("Sheet2").Range("A1:A20").Sort Key1:=Sheets("Sheet2").Range("A1:A20"), Order1:=xlAscending, Header:=xlNo, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
End Sub

 

[sijpie]

Dethanb, I'll look at it next week

 

[sijpie]

This should do the trick

Option Explicit


Sub SetupStaffRoster()
    Dim wsSR As Worksheet, wsOV As Worksheet
    Dim vIn As Variant, vOut 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)
    
    'now go through input array and gather the evaluators by row
    For lRi = 1 To 2
        For lCi = 5 To UB Step 6 'because of the merged cells, each 6 column to be checked
            sName = vIn(lRi, lCi)
            If Len(sName) 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 6 column to be checked
            sName = vIn(lRi, lCi)
            If Len(sName) 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

 

[sijpie]

Dethanb,
another request.
Next time that you post code, please use code brackets around your code to get it nicely formatted. See below in blue and red how to do it (or use the 'code' button to insert the code tags)

 

[dethanb]

I'll give it a try. Again, thank you for the help, and suggestions. I'll do so in the future.

 

[dethanb]

Option Explicit

Sub SetupStaffRoster()
    Dim wsSR As Worksheet, wsOV As Worksheet
    Dim vIn As Variant, vOut 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)
    
    'now go through input array and gather the evaluators by row
    For lRi = 1 To 2
        For lCi = 5 To UB Step 6 'because of the merged cells, each 6 column to be checked
            sName = vIn(lRi, lCi)
            If Len(sName) 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 6 column to be checked
            sName = vIn(lRi, lCi)
            If Len(sName) 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

The Macro you provided works very well, thank you.

I've been playing with it trying to do another check, but am failing at every attempt I make. What I'd like to incorporate into this Macro, is to check the cells for Font Color being used. If the Font Color is Black, then put it in the array, otherwise ignore it. I've been playing with IF THEN statements using "cell.fontcolor.ColorIndex = 1" but haven't been able to get it to work.

Is there an easy addition to this Macro to make it happen?

 

[sijpie]

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?