Copilot for Microsoft 365 Tech Accelerator
Feb 28 2024 07:00 AM - Feb 29 2024 10:30 AM (PST)
Microsoft Tech Community
SOLVED

VBA Needed - Move Row From Table to Different Table based on Cell Value

Copper Contributor

Hello...  I have a table with a column B called "Owned By".  I will create a Data Validation List with 8 names to select from in that column. 

I would like my team of 8 people to be able to select their name in column B and click a button to move the row to their table and delete the row from the source table.

I did try the following VBA to move a row from the source table to another, then delete the row from the source table by adding X in Column B:

 

Sub MoveCRLIJ()
Dim fCell As Range
Dim wsSearch As Worksheet
Dim wsDest As Worksheet
Dim lastRow As Long

Set wsSearch = Worksheets("CR-LIJ")
'Where should we move the data?
Set wsDest = Worksheets("Worksheet")

Application.ScreenUpdating = False

With wsSearch.Range("B:B")
Set fCell = .Find(what:="X", LookIn:=xlValues, lookat:=xlWhole, MatchCase:=False)

lastRow = wsDest.Cells(.Rows.Count, "A").End(xlUp).Offset(1).Row

wsSearch.Cells(fCell.Row, "A").Resize(1, 38).Copy
wsDest.Cells(lastRow, "A").PasteSpecial Paste:=xlPasteValues

fCell.EntireRow.Delete

'Try to find next one
Set fCell = .Find(what:="x", LookIn:=xlValues, lookat:=xlWhole, MatchCase:=False)
Loop


If lastRow <> 0 Then
wsDest.ListObjects("CRLIJWork").Resize wsDest.Range("A2:AR" & lastRow)
End If
End With

'Reset
Application.ScreenUpdating = True

End Sub

 

Now I need to know how to change this so the 8 people using this can move to their own table based on there name selected in column B.  Whatcha think??

7 Replies

@ChicagoLane 

To modify the VBA code to move rows to individual tables based on the name selected in column B, you can make the following changes. I'll assume that each person has a separate worksheet and that the worksheet names match the names in the "Owned By" list:

Vba Code is untested, please backup your file before you use it.

Sub MoveToIndividualTable()
    Dim wsSearch As Worksheet
    Dim wsDest As Worksheet
    Dim lastRow As Long
    Dim ownerName As String
    Dim destTableName As String

    Set wsSearch = Worksheets("CR-LIJ")
    Set wsDest = Nothing ' Initialize the destination worksheet

    ' Turn off alerts to avoid prompts when deleting rows
    Application.DisplayAlerts = False

    ' Loop through each row in column B
    For Each cell In wsSearch.Range("B2:B" & wsSearch.Cells(wsSearch.Rows.Count, "B").End(xlUp).Row)
        If cell.Value <> "" Then ' Check if the cell is not empty
            ownerName = cell.Value
            destTableName = "Table" & ownerName ' Adjust the table names as needed

            ' Check if the destination worksheet exists
            On Error Resume Next
            Set wsDest = Worksheets(destTableName)
            On Error GoTo 0

            If wsDest Is Nothing Then ' If the destination worksheet doesn't exist, create it
                Set wsDest = Sheets.Add(After:=Sheets(Sheets.Count))
                wsDest.Name = destTableName
                ' Add code here to set up the structure of the new worksheet, e.g., headers, formatting, etc.
            End If

            ' Find the last row in the destination worksheet
            lastRow = wsDest.Cells(wsDest.Rows.Count, "A").End(xlUp).Offset(1).Row

            ' Copy the row to the destination worksheet
            wsSearch.Cells(cell.Row, "A").Resize(1, 38).Copy
            wsDest.Cells(lastRow, "A").PasteSpecial Paste:=xlPasteValues

            ' Clear the row in the source worksheet
            wsSearch.Rows(cell.Row).Clear

            ' If needed, add code here to update the destination table structure
        End If
    Next cell

    ' Reset alerts
    Application.DisplayAlerts = True
End Sub

This modified code assumes that each person's worksheet is named "Table" followed by their name in the "Owned By" list. For example, if a person's name is "John," their worksheet should be named "TableJohn."

Before using this code, make sure to adjust the destination table names and consider any specific setup required for each person's worksheet. Additionally, you may need to modify the code to match the actual structure of your tables and worksheets. The text, steps and functions were created with the help of AI.

 

My answers are voluntary and without guarantee!

 

Hope this will help you.

Was the answer useful? Mark as best response and Like it!

This will help all forum participants.

@NikolinoDE 

Thank you for the response...  I am afraid I am a VBA newbie and found the original code I posted in another forum so I am struggling to add the missing code you noted to change the structure of the destination table, etc.  When testing your code, the row moved to a new worksheet as plain text and deleted from the source but left a blank row in the source table.  I tried to logic my way through picking pieces out of your code to update the original code and got an error.  Here is where I left off:

Sub MoveCRLIJ()
    Dim fCell As Range
    Dim wsSearch As Worksheet
    Dim wsDest As Worksheet
    Dim lastRow As Long
    Dim ownerName As String
    Dim destTableName As String
    
    'What sheet are we searching?
    Set wsSearch = Worksheets("CR-LIJ")
    'Where should we move the data?
    Set wsDest = Nothing
    
    'Prevent screen flicker
    Application.ScreenUpdating = False
    
    'We will be searching col B
    With wsSearch.Range("B:B")
        'Find the word "X"
        Set fCell = .Find(what:=ownerName, LookIn:=xlValues, lookat:=xlWhole, MatchCase:=False)
        If cell.Value <> "" Then ' Check if the cell is not empty
            ownerName = cell.Value
            destTableName = ownerName ' Adjust the table names as needed
        
         ' Check if the destination worksheet exists
            On Error Resume Next
            Set wsDest = Worksheets(destTableName)
            On Error GoTo 0
    
        'Repeat until we've moved all the records
        Do Until fCell Is Nothing
            'Found something, copy and delete
            'Where will we paste to?
            lastRow = wsDest.Cells(.Rows.Count, "A").End(xlUp).Offset(1).Row
            
            'Copy A:AL
            wsSearch.Cells(fCell.Row, "A").Resize(1, 38).Copy
            wsDest.Cells(lastRow, "A").PasteSpecial Paste:=xlPasteValues
     
            fCell.EntireRow.Delete
            
            'Try to find next one
            Set fCell = .Find(what:=ownerName, LookIn:=xlValues, lookat:=xlWhole, MatchCase:=False)
        Loop
        
        'Resize our table to match new data
        If lastRow <> 0 Then
            wsDest.ListObjects("CRLIJWork").Resize wsDest.Range("A2:AS" & lastRow)
         End If
    End With

    'Reset
    Application.ScreenUpdating = True
    
End Sub

 

I received an error- Compile error:  End With without With

Any idea if the above code will work or how to fix the error?

@ChicagoLane 

I think it is a small mistake in the code structure. The error is due to the misplaced End With.

Here is the corrected code:

Vba Code

Sub MoveCRLIJ()
    Dim fCell As Range
    Dim wsSearch As Worksheet
    Dim wsDest As Worksheet
    Dim lastRow As Long
    Dim ownerName As String
    Dim destTableName As String
    
    'What sheet are we searching?
    Set wsSearch = Worksheets("CR-LIJ")
    'Where should we move the data?
    Set wsDest = Nothing
    
    'Prevent screen flicker
    Application.ScreenUpdating = False
    
    'We will be searching col B
    With wsSearch.Range("B:B")
        'Find the word "X"
        Set fCell = .Find(what:=ownerName, LookIn:=xlValues, lookat:=xlWhole, MatchCase:=False)
        If Not fCell Is Nothing Then ' Check if the cell is not empty
            ownerName = fCell.Value
            destTableName = ownerName ' Adjust the table names as needed
        
            ' Check if the destination worksheet exists
            On Error Resume Next
            Set wsDest = Worksheets(destTableName)
            On Error GoTo 0
    
            'Repeat until we've moved all the records
            Do Until fCell Is Nothing
                'Found something, copy and delete
                'Where will we paste to?
                lastRow = wsDest.Cells(wsDest.Rows.Count, "A").End(xlUp).Offset(1).Row
                
                'Copy A:AL
                wsSearch.Cells(fCell.Row, "A").Resize(1, 38).Copy
                wsDest.Cells(lastRow, "A").PasteSpecial Paste:=xlPasteValues
         
                fCell.EntireRow.Delete
                
                'Try to find next one
                Set fCell = .Find(what:=ownerName, LookIn:=xlValues, lookat:=xlWhole, MatchCase:=False)
            Loop
            
            'Resize our table to match new data
            If lastRow <> 0 Then
                wsDest.ListObjects.Add(xlSrcRange, wsDest.Range("A1").CurrentRegion, , xlYes).Name = "CRLIJWork"
            End If
        End If
    End With

    'Reset
    Application.ScreenUpdating = True
End Sub

This should resolve the compile error. Additionally, I added a check If Not fCell Is Nothing before proceeding with further operations to avoid errors when Find does not locate the value.

@NikolinoDE 

 

Hello again...  seems like we are getting close...  I tried the new code and received the following error:

ChicagoLane_0-1705424366318.png

 

ChicagoLane_1-1705424382339.png

I attached a sample of the file Im trying to create.  The CR-LIJ Sheet is the sheet where I would like the team to be able to select their name in column B and click the button on top to move those columns to the end of the table on their own sheet.  Any ideas??

 

 

@ChicagoLane 

It seems like the wsDest worksheet is not being set correctly, leading to a runtime error '91'. To avoid this error, you should ensure that wsDest is properly assigned before trying to access its properties.

Here is an updated version of the code that includes additional checks:

Sub MoveCRLIJ()
    Dim fCell As Range
    Dim wsSearch As Worksheet
    Dim wsDest As Worksheet
    Dim lastRow As Long
    Dim ownerName As String
    Dim destTableName As String
    
    ' What sheet are we searching?
    Set wsSearch = Worksheets("CR-LIJ")
    
    ' Prevent screen flicker
    Application.ScreenUpdating = False
    
    ' We will be searching col B
    With wsSearch.Range("B:B")
        ' Find the word "X"
        Set fCell = .Find(what:="X", LookIn:=xlValues, lookat:=xlWhole, MatchCase:=False)
        
        ' Check if the cell is not empty
        If Not fCell Is Nothing Then
            ownerName = fCell.Value
            destTableName = "Table" & ownerName ' Adjust the table names as needed
            
            ' Check if the destination worksheet exists
            On Error Resume Next
            Set wsDest = Worksheets(destTableName)
            On Error GoTo 0
    
            ' If the destination worksheet doesn't exist, create it
            If wsDest Is Nothing Then
                Set wsDest = Sheets.Add(After:=Sheets(Sheets.Count))
                wsDest.Name = destTableName
                ' Add code here to set up the structure of the new worksheet, e.g., headers, formatting, etc.
            End If
            
            ' Repeat until we've moved all the records
            Do Until fCell Is Nothing
                ' Found something, copy and delete
                ' Where will we paste to?
                If Not wsDest Is Nothing Then
                    lastRow = wsDest.Cells(wsDest.Rows.Count, "A").End(xlUp).Offset(1).Row
                    
                    ' Copy A:AL
                    wsSearch.Cells(fCell.Row, "A").Resize(1, 38).Copy
                    wsDest.Cells(lastRow, "A").PasteSpecial Paste:=xlPasteValues
             
                    ' Clear the row in the source worksheet
                    wsSearch.Rows(fCell.Row).Clear
                End If
                
                ' Try to find the next one
                Set fCell = .Find(what:="X", LookIn:=xlValues, lookat:=xlWhole, MatchCase:=False)
            Loop
            
            ' If needed, add code here to update the destination table structure
        End If
    End With
    
    ' Reset
    Application.ScreenUpdating = True
End Sub

 

This updated code includes additional checks to ensure that wsDest is not Nothing before attempting to access its properties. Please try this version and see if it resolves the runtime error.

@NikolinoDE

 

Hello...  this looks very similar to the original VBA that was posted in your first reply that didn't work.  This time, I see this line referring to X in column B instead of the name we are selecting from the dropdown.

' We will be searching col B
    With wsSearch.Range("B:B")
        ' Find the word "X"
        Set fCell = .Find(what:="X", LookIn:=xlValues, lookat:=xlWhole, MatchCase:=False)

Any chance you can update and test in the sample file I posted??  Sorry to be a pain!!

best response confirmed by ChicagoLane (Copper Contributor)
Solution

I just received this code from another forum that worked perfectly:

Sub MoveCRLIJ()
     Dim V, R&, W
   With Sheet2.ListObjects(1)
        V = Filter(.Parent.Evaluate(Replace("TRANSPOSE(IF(#>0,ROW(#)-" & .Range.Row & "))", "#", .DataBodyRange.Columns(2).Address)), False, False)
    For R = 0 To UBound(V)
     If Evaluate("ISREF('" & .ListRows(V(R)).Range(2) & "'!A1)") Then
        W = .ListRows(V(R)).Range
   With Sheets(.ListRows(V(R)).Range(2).Text).Cells(Rows.Count, 1).End(xlUp)
       .Cells(2 + (.Text = "")).Resize(, UBound(W, 2)) = W
   End With
     Else
        V(R) = False
     End If
    Next
        V = Filter(V, False, False)
        For R = UBound(V) To 0 Step -1:  .ListRows(V(R)).Delete:  Next
   End With
End Sub
1 best response

Accepted Solutions
best response confirmed by ChicagoLane (Copper Contributor)
Solution

I just received this code from another forum that worked perfectly:

Sub MoveCRLIJ()
     Dim V, R&, W
   With Sheet2.ListObjects(1)
        V = Filter(.Parent.Evaluate(Replace("TRANSPOSE(IF(#>0,ROW(#)-" & .Range.Row & "))", "#", .DataBodyRange.Columns(2).Address)), False, False)
    For R = 0 To UBound(V)
     If Evaluate("ISREF('" & .ListRows(V(R)).Range(2) & "'!A1)") Then
        W = .ListRows(V(R)).Range
   With Sheets(.ListRows(V(R)).Range(2).Text).Cells(Rows.Count, 1).End(xlUp)
       .Cells(2 + (.Text = "")).Resize(, UBound(W, 2)) = W
   End With
     Else
        V(R) = False
     End If
    Next
        V = Filter(V, False, False)
        For R = UBound(V) To 0 Step -1:  .ListRows(V(R)).Delete:  Next
   End With
End Sub

View solution in original post