Want to be able to transfer/insert data from a listbox to a specific row in a table on sheet

[Paulo H]

Hi

I have created a listbox and can transfer data from it to a table ion a sheet but it will only populate the last row of the table. Sometimes it may be require do insert/transfer the data to a row mid table ie if something had been forgotten and needed to be added later. I can drag the the row up but I would prefer to add at the specific row. Can't fid a way to do it.

eg Table is populated to row 10. I then want to transfer an item from the list box and insert it in row 5, but this code only allows it to go to row 11

here is my code


Private Sub Transfer_Click()
ActiveSheet.Unprotect Password:="123"
Dim wrksht As Worksheet
Dim objListObj As ListObject


Dim i As Long
Dim listObj As ListObject
Set listObj = Sheets("Quote Form").ListObjects("Table1")
listObj.ListRows.Add , 1

listObj.DataBodyRange(listObj.ListRows.Count, 1) = ListBox1.List(ListBox1.ListIndex)


For i = 0 To Me.ListBox1.ListCount - 1
If Me.ListBox1.Selected(i) = True And Me.ListBox1.List(i, 1) <> "" Then
'Sheet1.Range("A12345").End(xlUp).Offset(1, 0) = Me.ListBox1.List(i, 0)
Sheet1.Range("A12345").End(xlUp).Offset(0, 3) = Me.ListBox1.List(i, 1)
Sheet1.Range("A12345").End(xlUp).Offset(0, 4) = Me.ListBox1.List(i, 3)
Sheet1.Range("A12345").End(xlUp).Offset(0, 2) = Me.ListBox1.List(i, 2)
Sheet1.Range("A12345").End(xlUp).Offset(0, 6) = Me.ListBox1.List(i, 4)
For x = 1 To 4
'Sheet1.Range("A123").End(xlUp).Offset(0, 1) = Me.ListBox1.List(i, x)
'Sheet1.Range("Table1").End(xlUp).Offset(3, 3) = Me.ListBox1.List(i, 3)

Next x

End If
Next i

End Sub


Many thanks

 

[Paulo H]

Replace all your code for this:

Private Sub Transfer_Click()
  Dim listObj As ListObject

  ActiveSheet.Unprotect Password:="123"
  Set listObj = Sheets("Quote Form").ListObjects("Table1")
  listObj.ListRows.Add (ActiveCell.Row)
  With ListBox1
    listObj.DataBodyRange(ActiveCell.Row, 1) = .List(.ListIndex, 0)
    listObj.DataBodyRange(ActiveCell.Row, 3) = .List(.ListIndex, 1)
    listObj.DataBodyRange(ActiveCell.Row, 4) = .List(.ListIndex, 3)
    listObj.DataBodyRange(ActiveCell.Row, 2) = .List(.ListIndex, 2)
    listObj.DataBodyRange(ActiveCell.Row, 6) = .List(.ListIndex, 4)
  End With
End Sub

Hi thanks for this but I am still gett

Replace all your code for this:

Private Sub Transfer_Click()
  Dim listObj As ListObject
 
  ActiveSheet.Unprotect Password:="123"
  Set listObj = Sheets("Quote Form").ListObjects("Table1")
  listObj.ListRows.Add (ActiveCell.Row)
  With ListBox1
    listObj.DataBodyRange(ActiveCell.Row, 1) = .List(.ListIndex, 0)
    listObj.DataBodyRange(ActiveCell.Row, 3) = .List(.ListIndex, 1)
    listObj.DataBodyRange(ActiveCell.Row, 4) = .List(.ListIndex, 3)
    listObj.DataBodyRange(ActiveCell.Row, 2) = .List(.ListIndex, 2)
    listObj.DataBodyRange(ActiveCell.Row, 6) = .List(.ListIndex, 4)
  End With
End Sub

Hi, thanks for this. I have replaced the code but still getting the runtime error 9, subscript out of range when I run debbug it highlights the line listObj.ListRows.ADD(ActiveCell.Row)
Thanks
Paul

 

[DanteAmor]

Which cell do you have selected at the time of execution?

You could share your file in the cloud.

You could upload a copy of your file to a free site such www.dropbox.com or google drive. Once you do that, mark it for 'Sharing' and you will be given a link to the file that you can post here. If the workbook contains confidential information, you could replace it with generic data.

 

[Paulo H]

Which cell do you have selected at the time of execution?

You could share your file in the cloud.

You could upload a copy of your file to a free site such www.dropbox.com or google drive. Once you do that, mark it for 'Sharing' and you will be given a link to the file that you can post here. If the workbook contains confidential information, you could replace it with generic data.

 

[Paulo H]

here is the link hopefully I have only removed the sensitive parts

Dropbox - File Deleted - Simplify your life

www.dropbox.com

 

[DanteAmor]

I had some problems with your table to insert rows and to identify the fields to insert each data, I only identified 4 fields.
Try the following:

Private Sub Transfer_Click()
  Dim listObj As ListObject, sh As Worksheet
  Dim nRow As Long, i As Long, j As Long
  
  'ActiveSheet.Unprotect Password:="123"
  
  Set sh = Sheets("Quote Form")
  Set listObj = sh.ListObjects("Table1")
  With ListBox1
    If .ListIndex > 0 Then
      If listObj.Range.Cells(2, 1) = "" Then
        nRow = 2
      Else
        i = listObj.HeaderRowRange.Row
        j = listObj.Range.Rows.Count
        sh.Rows(i + j).Insert
        listObj.ListRows.Add , False
        nRow = listObj.Range.Rows.Count
      End If
      listObj.Range.Cells(nRow, 1) = .List(.ListIndex, 0) 'item
      listObj.Range.Cells(nRow, 4) = .List(.ListIndex, 1) 'desc
      listObj.Range.Cells(nRow, 6) = .List(.ListIndex, 3) 'cost
      listObj.Range.Cells(nRow, 7) = .List(.ListIndex, 4) 'link
    End If
  End With
End Sub

 

[Paulo H]

I had some problems with your table to insert rows and to identify the fields to insert each data, I only identified 4 fields.
Try the following:

Private Sub Transfer_Click()
  Dim listObj As ListObject, sh As Worksheet
  Dim nRow As Long, i As Long, j As Long
 
  'ActiveSheet.Unprotect Password:="123"
 
  Set sh = Sheets("Quote Form")
  Set listObj = sh.ListObjects("Table1")
  With ListBox1
    If .ListIndex > 0 Then
      If listObj.Range.Cells(2, 1) = "" Then
        nRow = 2
      Else
        i = listObj.HeaderRowRange.Row
        j = listObj.Range.Rows.Count
        sh.Rows(i + j).Insert
        listObj.ListRows.Add , False
        nRow = listObj.Range.Rows.Count
      End If
      listObj.Range.Cells(nRow, 1) = .List(.ListIndex, 0) 'item
      listObj.Range.Cells(nRow, 4) = .List(.ListIndex, 1) 'desc
      listObj.Range.Cells(nRow, 6) = .List(.ListIndex, 3) 'cost
      listObj.Range.Cells(nRow, 7) = .List(.ListIndex, 4) 'link
    End If
  End With
End Sub

Hi this I am afraid still only adds the data to the end of the table and not at the that is highlighted. so if row 20 is highlighted ready to insert the data from the list box it actually adds to the next available row further down the table

Thank you I realise you have spent a lot of time with this already

 

[DanteAmor]

I don't understand why you want to do that, it's bad practice.
But you must have your reasons and if it is appropriate for you I have no problems.

For that, only the following is necessary:

Private Sub Transfer_Click()
  Cells(ActiveCell.Row, 1) = ListBox1.List(ListBox1.ListIndex, 0) 'item
  Cells(ActiveCell.Row, 4) = ListBox1.List(ListBox1.ListIndex, 1) 'desc
  Cells(ActiveCell.Row, 6) = ListBox1.List(ListBox1.ListIndex, 3) 'cost
  Cells(ActiveCell.Row, 7) = ListBox1.List(ListBox1.ListIndex, 4) 'link
End Sub

 

[Paulo H]

I don't understand why you want to do that, it's bad practice.
But you must have your reasons and if it is appropriate for you I have no problems.

For that, only the following is necessary:

Private Sub Transfer_Click()
  Cells(ActiveCell.Row, 1) = ListBox1.List(ListBox1.ListIndex, 0) 'item
  Cells(ActiveCell.Row, 4) = ListBox1.List(ListBox1.ListIndex, 1) 'desc
  Cells(ActiveCell.Row, 6) = ListBox1.List(ListBox1.ListIndex, 3) 'cost
  Cells(ActiveCell.Row, 7) = ListBox1.List(ListBox1.ListIndex, 4) 'link
End Sub

Yes This is perfect thank you so much for you effort and help. I understand why you say it is bad practice but I have a situation were to be able to insert at any point is really useful. Thank you again

 

[DanteAmor]

I'm glad to help you. Thanks for the feedback.