VBA If value exists in column of one table, offset the selection and copy that value into next available row in a different table.

[mrscottjr]

Hi all,

I'm hoping you can assist me. On my worksheet ("MAIN") I have two tables. One table is "EmployeeList" and the other table is "AccountHolders". The "EmployeeList" is a frequently updated table, while the "AccountHolders" table is one that only updates when the "UPDATE BUTTON" (actual Form Control button in my real file) is clicked. What I'm trying to get VBA to do is:

Once the "UPDATE" button is clicked, it should clear out the "Name" column in the "AccountHolders" table. Then I need it to go row by row in the "EmployeeList" list table, looking to see if there's a string/value in the "Largest Account" column. If there is a value in the column of that row, I want it to copy the "Name" from that row in the "EmployeeList" table and paste it into the next available row in the "Name" column of the "AccountHolders" table - and then proceed to the next row in the "EmployeeList" table that has a value in the "Largest Account" column, and do the same (copy that row's "Name" into the next available row of the "Name" column of "AccountHolders", and so on...

I've included below an example of what I have and what the desired output would be. Any assistance would be greatly appreciated!

Book2
	A	B	C	D	E	F	G	H	I	J
1									UPDATE BUTTON
2	Table Name = "AccountHolders"					Table Name = "EmployeeList"
3	Name	City	Years Active	Phone Number		Name	Company	City	Largest Account	Date Account Acquired
4						Johnathan L	Davidson	Chicago	ABC Corporate	1/22/2020
5						Marcus J	Ruby Pharm.	Dallas	Louiseville C&N	2/1/2020
6						Louise S	J & J	New York
7						Freddy M	Twos	Akron
8						Todd S	Bridgewater	Miami	United Cargo	5/29/2020
9						Jennifer H	Softsquare	Phoenix
10						Hugh G	Green Park	Austin	Phoenix Logistics	4/16/2019
11						Parker L.	ALC Pharm	Los Angeles
12
13
14
15	DESIRED OUTPUT AFTER CLICKING "UPDATE" BUTTON
16	Table Name = "AccountHolders"					Table Name = "EmployeeList"
17	Name	City	Years Active	Phone Number		Name	Company	City	Largest Account	Date Account Acquired
18	Johnathan L					Johnathan L	Davidson	Chicago	ABC Corporate	1/22/2020
19	Marcus J					Marcus J	Ruby Pharm.	Dallas	Louiseville C&N	2/1/2020
20	Todd S					Louise S	J & J	New York
21	Hugh G					Freddy M	Twos	Akron
22						Todd S	Bridgewater	Miami	United Cargo	5/29/2020
23						Jennifer H	Softsquare	Phoenix
24						Hugh G	Green Park	Austin	Phoenix Logistics	4/16/2019
25						Parker L.	ALC Pharm	Los Angeles
Sheet1

 

[Lian]

Sub copySample()

Dim d As Object
Dim arr As Variant
Dim iLast As Long
Dim k As Variant

iLast = Cells(Rows.Count, 1).End(xlUp).Row
arr = Range("F3").CurrentRegion
Set d = CreateObject("Scripting.Dictionary")

Range("A4:A" & iLast).ClearContents


For i = 2 To UBound(arr)
On Error Resume Next
    If arr(i, 4) <> "" Then
        d(arr(i, 1)) = arr(i, 4)
    End If
Next

k = Application.Transpose(d.keys)
Range("A4").Resize(d.Count) = k
Set d = Nothing

End Sub

 

[fadee2]

Another approach....

Sub mrscottjr()

Range("accountholders").ListObject.DataBodyRange.Delete
lremplist = ActiveSheet.Cells(Rows.Count, 9).End(xlUp).Row
lracthold = ActiveSheet.Cells(Rows.Count, 1).End(xlUp).Row

If lracthold = 4 Then
    x = lracthold
Else
    x = lracthold + 1
End If
  
    For i = 4 To lremplist
        If Cells(i, 9) <> "" Then
            Cells(x, 1) = Cells(i, 6)
            x = x + 1
        End If
    Next i
  
lremplist = ""
lracthold = ""

End Sub

 

[mrscottjr]

Thank you both! Is there a way to do this where it's referencing each table as listobjects and table columns/headers? There's a chance that some of my peers may be adding additional columns or moving things around, so it's not always going to be the 1st or 9th column where "Name" and "Largest Account" will be held...

 

[Fluff]

What version of Excel are you using?

I suggest that you update your Account details (or click your user name at the top right of the forum) so helpers always know what Excel version(s) & platform(s) you are using as the best solution often varies by version. (Don’t forget to scroll down & ‘Save’)

 

[mrscottjr]

Thanks for the advice on the Account Details. I've made the update per your suggestion.
I'm currently running Office 365 ProPlus and my desktop version of Excel is 2016 (Version 1808).

 

[Fluff]

Ok, how about

Sub mrscottjr()
   Dim Ary As Variant, Nary As Variant
   Dim r As Long, nr As Long, NameCol As Long, LargeCol As Long
   
   With Sheets("Sheet1").ListObjects("EmployeeList")
      Ary = .DataBodyRange.Value2
      NameCol = .ListColumns("Name").Index
      LargeCol = .ListColumns("Largest Account").Index
   End With
   ReDim Nary(1 To UBound(Ary), 1 To 1)
   
   For r = 1 To UBound(Ary)
      If Ary(r, LargeCol) <> "" Then
         nr = nr + 1
         Nary(nr, 1) = Ary(r, NameCol)
      End If
   Next r
   With Sheets("Sheet1").ListObjects("AccountHolders")
      If .ListRows.Count > 0 Then .DataBodyRange.Delete
      .InsertRowRange.Columns(1).Resize(nr).Value = Nary
   End With
End Sub

 

[mrscottjr]

This did the trick perfectly! Thank you so much!

 

[Fluff]

Glad we could help & thanks for the feedback.