VBA Code to Transfer Data from one Table to another based on Cell Value

[Falko26]

Hey Team,

I'm trying to transfer data between two tables on different sheets depending on the value of the Status Column.

Credit Snakehips for getting me this close.

I have 3 Codes. one for the module then one for each respective sheet I'm copying to.
This code works perfectly but I'm trying to tweak it to paste from one Table to another. Currently the data just gets pasted to the bottom row below the table and not actually inside of it.

Module Code

Sub MoveBasedOnValue(YsNo As String)

'Common Sub for a Code Module
Dim xRg As Range
Dim xCell As Range
Dim A As Long
Dim B As Long
Dim C As Long


Dim ToSheet As Worksheet
Dim FroSheet As Worksheet

Select Case YsNo
 Case "yes"
    Set ToSheet = Sheets("Returned")
    Set FroSheet = Sheets("Out")
Case "no"
    Set ToSheet = Sheets("Out")
    Set FroSheet = Sheets("Returned")
End Select

A = FroSheet.UsedRange.Rows.Count

B = ToSheet.UsedRange.Rows.Count

If B = 1 Then

If Application.WorksheetFunction.CountA(ToSheet.UsedRange) = 0 Then B = 0

End If

Set xRg = FroSheet.Range("H1:H" & A)

On Error Resume Next

Application.ScreenUpdating = False

For C = 1 To xRg.Count

If CStr(xRg(C).Value) = YsNo Then

xRg(C).EntireRow.Copy Destination:=ToSheet.Range("A" & B + 1)

xRg(C).EntireRow.Delete

If CStr(xRg(C).Value) = YsNo Then

C = C - 1

End If

B = B + 1

End If

Next

Application.ScreenUpdating = True

End Sub

Sheet 1

Private Sub Worksheet_Change(ByVal Target As Range)

'Sub for Returned sheet

Dim ToSht As String
Dim FroSht As String
Dim YsNo As String
Dim Z As Long
Dim xVal As String

On Error Resume Next

If Intersect(Target, Range("H:H")) Is Nothing Then Exit Sub

Application.EnableEvents = False

For Z = 1 To Target.Count

If Target(Z).Value > 0 Then
'********************************
YsNo = "no"
'**********************************
Call MoveBasedOnValue(YsNo)

End If

Next

Application.EnableEvents = True

End Sub

Sheet 2

Private Sub Worksheet_Change(ByVal Target As Range)

'Sub for Returned sheet

Dim ToSht As String
Dim FroSht As String
Dim YsNo As String
Dim Z As Long
Dim xVal As String

On Error Resume Next

If Intersect(Target, Range("H:H")) Is Nothing Then Exit Sub

Application.EnableEvents = False

For Z = 1 To Target.Count

If Target(Z).Value > 0 Then
'********************************
YsNo = "yes"
'**********************************
Call MoveBasedOnValue(YsNo)

End If

Next

Application.EnableEvents = True

End Sub

 

[tonyyy]

Where VBA is concerned, working with Tables (aka ListObjects) is different than working with Ranges. Chris Newman presents a nice overview in The VBA Guide to ListObject Excel Tables. At some point you might want to consider rewriting your code utilizing ListObjects.

As for a tweak to your existing code, you might try resizing the table to incorporate your copied/pasted row:

Dim tbl As ListObject
Dim rng As Range

Set tbl = ToSheet.ListObjects(1)
Set rng = ToSheet.Range(tbl.Name & "[#All]").Resize(tbl.Range.Rows.Count + 1, tbl.Range.Columns.Count)
tbl.Resize rng

I suggest placing this tweak just below your EntireRow.Copy statement.

Cheers,

Tony

 

[Falko26]

Hey tonyyy,

Thanks for the Reply! This workaround solves my current problem.

The link you provided seems very informative, I plan to dig into that soon here.

Thanks Again!

 

[tonyyy]

You're very welcome. Glad it worked out.

Happy Holidays!