VBA MACRO-使用列表框在Excel中动态选择列

Question

I have an excel file and what I did is that I add every column header to the listbox as items. Now, what I want to achieve is when I choose multiple items in listbox, it will copy the corresponding column and paste it to another workbook.

I have this code right now, it can only copy and paste the first column that I chose from the listbox. I hope someone could help me .

Private Sub CommandButton1_Click() ' generate result

Dim wkb As Workbook
Dim rng As Range
Dim cl As Object
Dim strMatch As String
Dim Size As Integer
Dim lRow As Long, lCol As Long
Dim rng1 As Range
Dim rng2 As Range
Dim rng3 As Range

Set rng1 = Cells.Find("*", [a1], xlFormulas, , xlByRows, xlPrevious)
Set rng2 = Cells.Find("*", [a1], xlFormulas, , xlByColumns, xlPrevious)
Set rng3 = Range([a1], Cells(rng1.Row, rng2.Column))

strMatch = ListBox2.List(0) 'Copying Respondent Number
Set rng = Range("A1:Z1")
For Each cl In rng
    If cl.Value = strMatch Then
        cl.EntireColumn.Copy 'Copy Selected Column
        Set wkb = Workbooks.Add 'Adding New Workbook
        ActiveSheet.Paste 'Paste Selected Column
        Exit For
    End If
Next cl

End Sub

Answer 1

proposed correction. This will create 1 workbook per selected column.

Private Sub CommandButton1_Click() ' generate result
Dim rng As Range
Dim cl As Object
Dim strMatch As String
Dim , i As Integer
Dim  lCol As Long
lCol = Cells(1, Columns.Count).End(xlToLeft).Column
For i = 0 To ListBox1.ListCount - 1
 strMatch = ListBox1.List(i) 'Copying Respondent Number
 Set rng = Range(Cells(1, 1), Cells(1, lCol))
 Set cl = rng.Find(strMatch, lookat:=xlWhole)
 If Not cl Is Nothing Then
        cl.EntireColumn.Copy 'Copy Selected Column
        Set wkb = Workbooks.Add 'Adding New Workbook
        ActiveSheet.Paste 'Paste Selected Column
 End If
Next i
End Sub

Answer 2

you could try this

Option Explicit

Private Sub CommandButton1_Click()
    Dim i As Long
    Dim colsIndexStrng As String
    Dim copyRng As Range

    With Me.ListBox2
        For i = 0 To .ListCount - 1
            If .selected(i) Then colsIndexStrng = colsIndexStrng & Cells(1, i + 1).Address(False, False) & ","
        Next i
    End With

    If colsIndexStrng = "" Then Exit Sub

    Set copyRng = Range(Left(colsIndexStrng, Len(colsIndexStrng) - 1)).EntireColumn
    With Workbooks.Add
        copyRng.Copy ActiveSheet.Range("A1")
    End With
    ActiveWorkbook.Close True
End Sub