copy cels which have data to another worksheet, in a list form

Hello,

I have a Workbook that contains a number of worksheets related to estimating costs. On one worksheet I have a several sections that use drop down boxes to pick the material of choice, one material per cel. I have 10 empty cels per section that can be filled or not depending on what is required.

What I would like to do is have any cels which have a material selected in them to be copied to another worksheet to make a materials list. As I said there are a number of sections, each with a partial list. Ideally, all the information from these sections would be copied to the other worksheet and fill cels with no empty spaces between them.

In short, perhaps 2 cels from column A, 5 cells from column B and 1 cel from column C all forming a sequential list in worksheet - Materials.

Any suggestions on how to accomplish this? Thanks!

Here is some VBA to get you started. Go to the VBA IDE (alt-F11), insert a new module and paste in this code:

Option Explicit

Public Sub DropDown_Change()

    Call UpdateArray(Worksheets("Sheet1"), Worksheets("Materials").Range("A5"))

End Sub
Public Sub UpdateArray(ByVal wksSource As Worksheet, ByVal rngDest As Excel.Range)

    Dim rngCurr         As Excel.Range
    Dim shpCurr         As Shape

    Dim arrOut()        As Variant
    Dim intIndex        As Integer
    Dim intPos          As Integer
    Dim strRange        As String
    Dim lngLastRow      As Long
    Dim intCol          As Integer

    ReDim arrOut(1 To 1)
    For Each shpCurr In wksSource.Shapes
        If shpCurr.FormControlType = xlDropDown Then
            intIndex = Range(shpCurr.ControlFormat.LinkedCell).Value
            If intIndex > 0 Then
                strRange = shpCurr.ControlFormat.ListFillRange
                intPos = InStr(1, strRange, "!")
                If intPos > 0 Then
                    Set rngCurr = ThisWorkbook.Worksheets(Left(strRange, intPos - 1)).Range(Mid(strRange, intPos + 1))
                Else
                    Set rngCurr = Range(strRange)
                End If
                If rngCurr.Cells(intIndex, 1).Value2 > "" Then
                    If arrOut(UBound(arrOut)) > "" Then
                        ReDim Preserve arrOut(1 To UBound(arrOut) + 1)
                    End If
                    arrOut(UBound(arrOut)) = rngCurr.Cells(intIndex, 1).Value2
                End If
            End If
        End If
    Next shpCurr

    intCol = rngDest.Column
    lngLastRow = rngDest.Parent.Columns(intCol).Find(What:="*", After:=Cells(1, intCol), _
        SearchOrder:=xlByRows, SearchDirection:=xlPrevious, _
        LookAt:=xlPart, LookIn:=xlValues).Row
    If lngLastRow > rngDest.Row Then
        rngDest.Resize(lngLastRow - rngDest.Row).ClearContents
    End If
    If arrOut(UBound(arrOut)) > "" Then
        rngDest.Resize(UBound(arrOut), 1) = Application.Transpose(arrOut)
    End If
        
End Sub

Assign the DropDown_Change macro to each of your drop-down boxes, and change it to match your worksheet. The first parameter (Worksheets("Sheet1")) is the worksheet name that contains the drop-down boxes, the second (Worksheets("Materials").Range("A5")) is a pointer to the first cell where you want the list to end up.

The procedure will loop through all of the controls on the source worksheet, and check if the drop-downs linked cells have a value in them. The linked cell value is only an index into your list, so it next checks that the value selected is not a blank. If it isn't blank, then it adds the value to an array. Once all of the dropdowns have been selected, it clears out the cells from the destination to the bottom and copies the array to the destination.