Forum Discussion
VBA Needed - Move Row From Table to Different Table based on Cell Value
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
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?
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 SubThis 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.
Hello again... seems like we are getting close... I tried the new code and received the following error:
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??
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 SubThis 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.
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!!
