Цитирование через списки в excel vba

Question

Есть ли очевидная проблема со следующими кодами? Я хочу перебрать все списки и заполнить выбранные элементы.

Dim lRw As Integer 
Dim iX As Integer, iY As Integer 
Dim i As Integer 

For i = 1 To 10 

With ActiveSheet 
.Columns(i + 10).ClearContents 
End With 

    For iX = 0 To ListBox(i).ListCount - 1 
     If ListBox(i).Selected(iX) = True Then 
     With Sheet1 
      lRw = .Cells(.Rows.Count, i + 11).End(xlUp).Row + 1 
      For iY = 0 To ListBox(i).ColumnCount - 1 
       .Cells(lRw, iY + i).Value = ListBox(i).List(iX, iY) 
      Next iY 
     End With 

     End If 
    Next iX 
Next i 

Answer 1

С UNKOWN числом ListBoxes и неизвестным количеством выбранных элементов каждым, я бы построить строку с результатами, а затем разделить строку на каретке возвращает Chr(10) для каждой строки (каждый выбранный элемент в ListBox) а затем используйте текст в столбцы, чтобы получить все в правильных ячейках. Это будет выглядеть следующим образом:

Sub tgr() 

    Dim wsLists As Worksheet 
    Dim wsDest As Worksheet 
    Dim ctrl As OLEObject 
    Dim strOutput As String 
    Dim arrOutput() As String 
    Dim i As Long, j As Long 

    Set wsLists = Sheets("Sheet1") 'The sheet containing the listboxes 
    Set wsDest = Sheets("Sheet2") 'The sheet where the output will go 

    For Each ctrl In wsLists.OLEObjects 
     If TypeName(ctrl.Object) = "ListBox" Then 
      For i = 0 To ctrl.Object.ListCount - 1 
       If ctrl.Object.Selected(i) Then 
        If Len(strOutput) > 0 Then strOutput = strOutput & Chr(10) 
        For j = 0 To ctrl.Object.ColumnCount - 1 
         strOutput = strOutput & ctrl.Object.List(i, j) & vbTab 
        Next j 
       End If 
      Next i 
     End If 
    Next ctrl 

    If Len(strOutput) > 0 Then 
     wsDest.Range("K:T").ClearContents 
     arrOutput = Split(strOutput, Chr(10)) 
     With wsDest.Cells(Rows.Count, "K").End(xlUp).Offset(1).Resize(UBound(arrOutput) - LBound(arrOutput) + 1) 
      .Value = Application.Transpose(arrOutput) 
      .TextToColumns Tab:=True 
     End With 
     Erase arrOutput 
    End If 

End Sub