Copy values from table to table based on looked up condition with VBA?

Lil2606

Board Regular
Joined
Jan 29, 2019
Messages
79
Hi all,

Here is my post on excelforum: https://www.excelforum.com/excel-pr...riteria-and-vba-with-example.html#post5068295

I have explained it in much detail there, and there is an example workbook uploaded there as well.

I have 4 outcome tables (East, North, West and South) and I have 2 Data tables on Data1 sheet and on Data2 sheet.

I'm trying to copy the the data from tables on Data1 and Data2 to the Outcome tables, based on the "Crop Location", but Crop Location is not a column in either data table. Crop Name is in the Data tables and on the Admin sheet I have a Loc_Table that for each Crop Name has a Location beside it.

So it should be something like.. For Row(i) look up Location in sheet(Admin) Loc_Table, if it is East then copy Row(i) Column(Fruit Name) value, to Sheet(Outcome) EastTable first empty row Fruit Name column, and then the same for each column, because they are mixed up compared to each other so I can't just copy rows..

With VBA, as I will not be the one to create these tables in the future and I'd rather just have a button pressed and all the things generated than having to explain all the how to write which formula and manually copy paste, as its a risk of data loss.

Could someone help me with this please?
 

Excel Facts

Square and cube roots
The =SQRT(25) is a square root. For a cube root, use =125^(1/3). For a fourth root, use =625^(1/4).
The macro considers the names of sheets and tables are as they come in your file

Put the following code in a module. Run macro Copy_values_from_table

Code:
Option Explicit


Sub Copy_values_from_table()
    ' Copy values from table to table based on looked up condition with VBA
    '
    Dim ws1 As Worksheet, ws2 As Worksheet, ws3 As Worksheet, ws4 As Worksheet
    Dim ori1 As Variant, des1 As Variant, ori2 As Variant, des2 As Variant, wTables As Variant, tbl As Object
    Dim j As Double


    Application.ScreenUpdating = False
    
    Set ws1 = Sheets("Data1")
    Set ws2 = Sheets("Data2")
    Set ws3 = Sheets("Outcome")
    Set ws4 = Sheets("Admin")


    
    'Delete all table rows except first row
    wTables = Array("EastTable", "NorthTable", "WestTable", "SouthTable")
    On Error Resume Next
    For j = LBound(wTables) To UBound(wTables)
        Set tbl = ws3.ListObjects(wTables(j))
        With tbl.DataBodyRange
            If .Rows.Count > 1 Then .Offset(1, 0).Resize(.Rows.Count - 1, .Columns.Count).Rows.Delete
        End With
        tbl.DataBodyRange.Rows(1).ClearContents
    Next
    On Error GoTo 0
    
    'Filla Data1
    des1 = Array("A", "B", "C", "D", "E", "F", "J", "K", "P")
    ori1 = Array("A", "B", "C", "J", "D", "E", "H", "I", "G")
    Call FillOutcome(ws1, ws3, ws4, "E", "C", "J", des1, ori1, "G", "H")


    'Filla Data2
    des2 = Array("A", "B", "D", "E", "F")
    ori2 = Array("A", "B", "C", "E", "D")
    Call FillOutcome(ws2, ws3, ws4, "D", "B", "C", des2, ori2, "G", "H")


    On Error Resume Next
    For j = LBound(wTables) To UBound(wTables)
        ws3.ListObjects(wTables(j)).ListRows(1).Range.Delete
    Next
    On Error GoTo 0


    Application.ScreenUpdating = True
    
    MsgBox "End"
End Sub
'
Sub FillOutcome(ws1, ws3, ws4, col_Name, col_Frui, col_Care, des1, ori1, col_Trial, col_Type)
    
    Dim wName As String, wLoca As String, wTable As String, wFrui As String, wCare As String, wTrial As String, wType As String
    Dim ini As Double, fin As Double, u1 As Double, i As Double, j As Double
    Dim b As Object, valor As Variant
    
    u1 = ws1.Range("A" & Rows.Count).End(xlUp).Row
    For i = 2 To u1
        wName = ws1.Cells(i, col_Name).Value
        wFrui = ws1.Cells(i, col_Frui).Value
        wCare = ws1.Cells(i, col_Care).Value
        Set b = ws4.ListObjects("Loc_Table").Range.Columns(1).Find(wName, lookat:=xlWhole)
        If Not b Is Nothing Then
            wLoca = b.Offset(0, 1).Value
            wTable = wLoca & "Table"
            ini = ws3.ListObjects(wTable).Range.Cells(1, 1).Row
            fin = ws3.ListObjects(wTable).Range.Rows.Count + ini
            ws3.Rows(fin).Insert
            ws3.ListObjects(wTable).Resize Range("A" & ini & ":P" & fin)
            
            Set b = ws4.ListObjects("Trials_List").Range.Columns(1).Find(wFrui, lookat:=xlWhole)
            If Not b Is Nothing Then wTrial = "Yes" Else wTrial = "No"
                
            Set b = ws4.ListObjects("CareType_List").Range.Columns(1).Find(wCare, lookat:=xlWhole)
            If Not b Is Nothing Then wType = b.Offset(0, 1).Value Else wType = ""
                
            For j = LBound(ori1) To UBound(ori1)
                ws3.Cells(fin, des1(j)).Value = ws1.Cells(i, ori1(j)).Value
            Next
            ws3.Cells(fin, col_Trial).Value = wTrial
            ws3.Cells(fin, col_Type).Value = wType
            
        End If
    Next


End Sub
 
Last edited:
Upvote 0
Wow... Well I'm just learning VBA at this point.. I feel like this is quite above my head.. but its awesome. Works like a charm! Thank you!
 
Upvote 0

Forum statistics

Threads
1,223,229
Messages
6,170,881
Members
452,364
Latest member
springate

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top