VBA MACRO - Dynamisch Spalten in Excel mit ListBox

Question

Ich habe eine Excel-Datei und was ich getan habe ist, dass ich jede Spaltenüberschrift der Listbox als Elemente hinzufügen. Nun, was ich erreichen möchte, ist, wenn ich mehrere Elemente in Listbox wähle, wird es die entsprechende Spalte kopieren und in eine andere Arbeitsmappe einfügen.

Ich habe diesen Code gerade, er kann nur die erste Spalte kopieren und einfügen, die ich aus der Listbox auswählte. Ich hoffe, jemand könnte mir helfen.

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

Sie diesen

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 

Answer 2

vorgeschlagene Korrektur. Dies erstellt 1 Arbeitsmappe pro ausgewählter Spalte.

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