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

[Lil2606]

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?

 

[DanteAmor]

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

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

 

[Lil2606]

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!

 

[DanteAmor]

I'm glad to help you. Thanks for the feedback.