如何从excel下拉列表中提取项目？

Question

我的xls文件包含许多下拉列表，其中包含大量项目（集合中的元素），我希望将它们复制到文本编辑器中。

任何想法或信息对我都有帮助。

Answer 1

打开您想要列表的工作簿，将其粘贴到新模块中并运行它（ ALT F11 → ALT 我→ ALT 中号→ F5 ）。它遍历控件并列出文本文件中的下拉列表（与工作簿在同一路径中），并在记事本中打开它。

Sub ListAllCombos()
'loop through active workbook: sheets -> shapes -> dropdowns -> input ranges
Dim ws As Worksheet, shp As Shape, c As Range, r As Range
Dim x As Integer, strOut As String
strOut = "   Workbook Name: " & Application.ActiveWorkbook.FullName & vbCrLf
For Each ws In ActiveWorkbook.Worksheets
    strOut = strOut & "--Worksheet Name: " & ws.Name & vbCrLf
    For Each shp In ws.Shapes
        If shp.FormControlType = xlDropDown Then
            x = x + 1
            strOut = strOut & "--DropDown Name: " & shp.Name & vbCrLf
            Set r = Range(shp.ControlFormat.ListFillRange)
            For Each c In r
                strOut = strOut & Worksheets(ws.Name).Range(c.Address) & vbCrLf
            Next c
            strOut = strOut & vbCrLf
        End If
    Next shp
Next ws

If x = 0 Then
    MsgBox "No dropdowns."
    Exit Sub
End If
strOut = strOut & "(" & x & " dropdowns)" & vbCrLf

'write to text file & open in Notepad
Dim fName, RetVal
fName = Application.ActiveWorkbook.Path & "\DropDowns (" & Application.ActiveWorkbook.Name & ").txt"
If Dir(fName) <> "" Then If MsgBox("Existing file will be replaced.", vbOKCancel, "Replace") = vbCancel Then Exit Sub
Open fName For Output As #1
Write #1, strOut & vbCrLf & Now()
Close #1
If MsgBox("File created:" & vbCrLf & x & " listboxes saved in file: " & fName, vbOKCancel, "Open list in Notepad?") = vbCancel Then Exit Sub
RetVal = Shell("C:\WINDOWS\Notepad.EXE " & fName, 1)
'Debug.Print strOut
End Sub