Copy Non Contigous Rows from One Sheet to Another

F

farhad

New member
Joined
Jul 17, 2018
Messages
17
Reaction score
0
Points
1
Excel Version(s)
2013
Good Day

I am new to this forum.

I having a issue I am trying to copy non contiguous rows from one sheet to another.

The code below works perfectly fine when the Asset is highlighted on the list Box. Due to the number of records, I use the search option and the record is found and when I try to move the Asset to another sheet, the first record on the list is selected and moved to Sheet7 which is incorrect.


The code I have is as follows

Code: 
Private Sub Image37_Click()           'Asset Transfer to New Sheet
Worksheets("Sheet7").Unprotect password:="Secret"
Dim lngSelected As Long, lngRows As Long
Dim CopyRng As Range
Dim lo As ListRow
Set lo = Sheets("Sheet7").ListObjects("Table1457").ListRows.Add
If ListBox1.Text = "" Then
        MsgBox "Select a Record to Transfer to Asset Disposal List...", vbCritical
            Exit Sub
                End If
If MsgBox("Would you like to Transfer Asset to Asset Disposal List.  This will remove record from Asset Register and cannot be undone...?", vbQuestion + vbYesNo) <> vbYes Then
Exit Sub
End If
For lngSelected = 0 To Me.ListBox1.ListCount - 1
  
    If Me.ListBox1.Selected(lngSelected) Then
  
        lngRows = lngSelected + 4
        Me.ListBox1.RemoveItem lngSelected
         
        With Sheets("sheet4")
        
            Set CopyRng = Union(.Range(.Cells(lngRows, 1), .Cells(lngRows, 6)), .Range(.Cells(lngRows, 41), .Cells(lngRows, 44)))
             
            CopyRng.Copy
            lo.Range.PasteSpecial Paste:=xlPasteValues
            
           .Rows(lngRows).Delete
        End With
    End If
Next lngSelected
MsgBox "Rows " & lngRows & " Copied To Asset Disposal Sheet"
MsgBox "Asset Transferred to Asset Disposal List and removed from Asset Register!"
Application.CutCopyMode = False
Sheets("Sheet7").Protect
Sheets("Sheet4").Protect
 End Sub


I have attached sample sheet for clarity

The password for Sheet4 is Secret

Thanks
 

Attachments

  • Asset Tagging V3_8.xlsm
    480.9 KB · Views: 19
HI Simon

The data that I search on from Sheet4 must be moved to Sheet7 and deleted from Sheet4
 
What do we need to enter, and where, in order to immediately get to the issue you have?
 
Yes
You need to search on the ALB Tag
 
You need to Enter the ALB Tag
This is entered on the userform on the search button
 
Yes data searched on Sheet4 must be moved to Sheet7 and deleted from Sheet4
 
Your issue is here
Code: 
For lngSelected = 0 To Me.ListBox1.ListCount - 1
  
    If Me.ListBox1.Selected(lngSelected) Then
  
        lngRows = lngSelected + 4
this works when you load the entire table into the list box and the first row in the list box is the first row in the table and the second row in the list box is the second row in the table, and so on but once you load filtered data into the list box that no longer holds true.

You need to use a unique ID column so each record in the table is uniquely identified.
Load that column into the list box also, then use that ID from the selected row to find the table row to be working with.
 
Dear Nos

Thanks for the feedback and assistance. Can you please guide me as how to I do this on the actual sheet.
I am guessing the following:
1. Add another column with numbers

And secondly how I modify the code ?

Thanks

Regards
 
If ALB Tag is unique id of items, use that.
Something along the lines of...
Code: 
    For lngSelected = 0 To Me.ListBox1.ListCount - 1
        If Me.ListBox1.Selected(lngSelected) Then
            With Sheets("sheet4")

                lngRows = .Range("F:F").Find(What:=Me.ListBox1.List(lngSelected, 5), _
                        LookIn:=xlValues, LookAt:=xlWhole, SearchOrder:=xlByRows, _
                        SearchDirection:=xlNext, MatchCase:=False).Row
                
                Set CopyRng = Union(.Range(.Cells(lngRows, 1), .Cells(lngRows, 6)), .Range(.Cells(lngRows, 39), .Cells(lngRows, 44)))
                CopyRng.Copy
                lo.Range.PasteSpecial Paste:=xlPasteValues
               .Rows(lngRows).Delete

            End With
            
            Me.ListBox1.RemoveItem lngSelected
            Exit For
        End If
    Next lngSelected
 
Hi Nos

Just a huge thank you. Your code worked out perfectly fine.
Once again thanks a million for your assistance
Regards
 
You must log in or register to reply here.
Back
Top