Agregar Selección multiple de Listbox en VBA a tabla de Access
Estoy haciendo un UserForm donde pueda elegir dos filas de un listbox y copie esas filas en una tabla de Access. Hasta ahora he conseguido hacerlo para una fila, pero no encuentro como hacerlo para que me agregue la segunda fila en la tabla.
Adjunto el código:
Private Sub CommandButton2_Click()
Set cn = New ADODB.Connection
Set rs = New ADODB.Recordset
If Me.ListBox1.ListIndex < 0 Then
MsgBox "No se ha elegido ningún registro", vbExclamation, "EXCELeINFO"
Else
End If
fila = 1
For x = 0 To ListBox1.ListCount - 1
If ListBox1.Selected(x) = True Then
cn.Open "Provider=Microsoft.ACE.OLEDB.12.0; " & "data source=" & ThisWorkbook.Path & "\BD_Transporte.accdb;"
rs.Open "RENDICIONES2", cn, adOpenKeyset, adLockOptimistic, adCmdTable
'agregar registros
With rs
.AddNew
.Fields("Conductor") = Me.ComboBox1.Value
.Fields("Fecha_Inicio_Viaje") = ListBox1.List(x, 0)
.Fields("Cliente_salida") = ListBox1.List(x, 1)
fila = fila + 1
.Update
End With
rs.Close
Set rs = Nothing
cn.Close
Set cn = Nothing
MsgBox ("LISTO"), vbInformation, "AVISO"
Application.ScreenUpdating = True
Application.DisplayAlerts = True
Unload Me
End If
Next
End Sub
H o l a:
Supongo que es porque estás cerrando la conexión. Pon el cierre después del Next:
Private Sub CommandButton2_Click()
'
Dim cn As ADODB.Connection, rs As ADODB.Recordset
Set cn = New ADODB.Connection
Set rs = New ADODB.Recordset
'
If Me.ListBox1.ListIndex < 0 Then
MsgBox "No se ha elegido ningún registro", vbExclamation, "EXCELeINFO"
Exit Sub
End If
'
cn.Open "Provider=Microsoft.ACE.OLEDB.12.0; " & "data source=" & ThisWorkbook.Path & "\BD_Transporte.accdb;"
rs.Open "RENDICIONES2", cn, adOpenKeyset, adLockOptimistic, adCmdTable
'
fila = 1
For x = 0 To ListBox1.ListCount - 1
If ListBox1.Selected(x) = True Then
'agregar registros
With rs
.AddNew
.Fields("Conductor") = Me.ComboBox1.Value
.Fields("Fecha_Inicio_Viaje") = ListBox1.List(x, 0)
.Fields("Cliente_salida") = ListBox1.List(x, 1)
fila = fila + 1
.Update
End With
End If
Next
'
rs.Close
Set rs = Nothing
cn.Close
Set cn = Nothing
MsgBox ("LISTO"), vbInformation, "AVISO"
Application.ScreenUpdating = True
Application.DisplayAlerts = True
Unload Me
End SubSal u dos
