VBA MACRO - Excelで列を動的に選択するListBoxを使用して

Question

私はExcelファイルを持っており、リストボックスにすべての列見出しを項目として追加しています。今、私が達成したいのは、リストボックスで複数の項目を選択したときに、対応する列をコピーして別のワークブックに貼り付けることです。

私は今すぐこのコードを持っています。リストボックスから選択した最初の列のみをコピーして貼り付けることができます。誰かが私を助けてくれることを願っている

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

あなたはあなたの説明で、この

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

修正を提案しました。これにより、選択した列ごとに1つのワークブックが作成されます。

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