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

New Member
Joined
Jul 24, 2015
Messages
41
Office Version
  1. 365
  2. 2016
Platform
  1. Windows
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
ABCDEFGHIJ
1UPDATE BUTTON
2Table Name = "AccountHolders"Table Name = "EmployeeList"
3NameCityYears ActivePhone NumberNameCompanyCityLargest AccountDate Account Acquired
4Johnathan LDavidsonChicagoABC Corporate1/22/2020
5Marcus JRuby Pharm.DallasLouiseville C&N2/1/2020
6Louise SJ & JNew York
7Freddy MTwosAkron
8Todd SBridgewaterMiamiUnited Cargo5/29/2020
9Jennifer HSoftsquarePhoenix
10Hugh GGreen ParkAustinPhoenix Logistics4/16/2019
11Parker L.ALC PharmLos Angeles
12
13
14
15DESIRED OUTPUT AFTER CLICKING "UPDATE" BUTTON
16Table Name = "AccountHolders"Table Name = "EmployeeList"
17NameCityYears ActivePhone NumberNameCompanyCityLargest AccountDate Account Acquired
18Johnathan LJohnathan LDavidsonChicagoABC Corporate1/22/2020
19Marcus JMarcus JRuby Pharm.DallasLouiseville C&N2/1/2020
20Todd SLouise SJ & JNew York
21Hugh GFreddy MTwosAkron
22Todd SBridgewaterMiamiUnited Cargo5/29/2020
23Jennifer HSoftsquarePhoenix
24Hugh GGreen ParkAustinPhoenix Logistics4/16/2019
25Parker L.ALC PharmLos Angeles
Sheet1
 

Excel Facts

Difference between two dates
Secret function! Use =DATEDIF(A2,B2,"Y")&" years"&=DATEDIF(A2,B2,"YM")&" months"&=DATEDIF(A2,B2,"MD")&" days"

Lian

New Member
Joined
Jan 26, 2021
Messages
34
Office Version
  1. 365
  2. 2019
  3. 2016
Platform
  1. Windows
VBA Code:
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
 

Attachments

  • 屏幕截图 2021-03-08 141230.jpg
    屏幕截图 2021-03-08 141230.jpg
    117.5 KB · Views: 3

fadee2

Active Member
Joined
Nov 7, 2020
Messages
337
Office Version
  1. 2019
Platform
  1. Windows
Another approach....
VBA Code:
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

New Member
Joined
Jul 24, 2015
Messages
41
Office Version
  1. 365
  2. 2016
Platform
  1. Windows
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

MrExcel MVP, Moderator
Joined
Jun 12, 2014
Messages
56,856
Office Version
  1. 365
Platform
  1. Windows

ADVERTISEMENT

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

New Member
Joined
Jul 24, 2015
Messages
41
Office Version
  1. 365
  2. 2016
Platform
  1. Windows
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

MrExcel MVP, Moderator
Joined
Jun 12, 2014
Messages
56,856
Office Version
  1. 365
Platform
  1. Windows

ADVERTISEMENT

Ok, how about
VBA Code:
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
 
Solution

mrscottjr

New Member
Joined
Jul 24, 2015
Messages
41
Office Version
  1. 365
  2. 2016
Platform
  1. Windows
This did the trick perfectly! Thank you so much!
 

Fluff

MrExcel MVP, Moderator
Joined
Jun 12, 2014
Messages
56,856
Office Version
  1. 365
Platform
  1. Windows
Glad we could help & thanks for the feedback.
 

Watch MrExcel Video

Forum statistics

Threads
1,130,128
Messages
5,640,281
Members
417,133
Latest member
caaronh85

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
Top