VBA Help - Extract columns to a new sheet based on a list of Account numbers

[shynot]

Hi all,

I'd like to do the following via a Macro, but am unsure of how/what the code should look like. I have a list of accounts with their related account numbers in Sheet 1, and a list of transactions in Sheet 2 with other details such as date, reference, etc.

What I'd like the Macro to do is to loop through the list of account numbers from Sheet 1, filter and extract the relevant columns from Sheet 2, and copy / paste those columns in Sheet 3. Ideally this would be a loop with the account details being pasted one below the other in sequence in Sheet 3.

I've been able to write simple VBA code to do this for one account number, and doesn't work with the second onwards. I apologise if this is not clear enough as I'm just starting out at VBA coding. Would be grateful for any and all help!

 

[DanteAmor]

Hi and welcome to MrExcel.
Could you put some examples

 

[shynot]

Hi Dante,

So in Sheet 1, I'll have the following details (Example):

	A	B
1	Account no.	Account name
2	12345	Tax
3	23456	Salaries

And in Sheet 2, I'll have the following details:

	A	B	C	D	E
1	Account no.	Reference	Type	Date	Amount
2	12345	Tax - Jan	AC	1/1/21	50
3	12345	Tax - Feb	AC	1/2/21	50
4	67890	Others	AC	1/1/21	100
5	23456	Salaries - Jan	AC	1/1/21	50
6	23456	Salaries - Feb	AC	1/2/21	50
7	45678	Others	AC	1/1/21	100

So ideally in Sheet 3, I'd have the macro filter and copy Sheet 2, and output the following details using the account numbers in Row A from Sheet 1:

	A	B	C	D
1	12345	Tax
2		Tax - Jan	1/1/21	50
3		Tax - Feb	1/2/21	50
4
5	23456	Salaries
6		Salaries - Jan	1/1/21	50
7		Salaries - Feb	1/2/21	100

I realise the reason my macro doesn't work as how I intended it is because it has hard-coded values and not variables. Ie. Autofilter variable is "123456" as opposed to Cell A2. Hope this is clear. Thank you

 

[DanteAmor]

Try this:

Sub Extract_columns()
  Dim a As Variant, b As Variant
  Dim sh1 As Worksheet, sh2 As Worksheet, sh3 As Worksheet
  Dim i As Long, k As Long, lr As Long
  Dim c As Range, f As Range
  
  Application.ScreenUpdating = False
  Set sh1 = Sheets("Sheet1")
  Set sh2 = Sheets("Sheet2")
  Set sh3 = Sheets("Sheet3")
  
  a = sh1.Range("A2", sh1.Range("B" & Rows.Count).End(3)).Value2
  b = sh2.Range("A2", sh2.Range("E" & Rows.Count).End(3)).Value2
  
  If sh2.AutoFilterMode Then sh2.AutoFilterMode = False
  lr = sh2.Range("A" & Rows.Count).End(3).Row
  sh3.Rows("2:" & Rows.Count).ClearContents
  
  k = 2
  For i = 1 To UBound(a, 1)
    If sh2.AutoFilterMode Then sh2.AutoFilterMode = False
    Set f = sh2.Range("A:A").Find(a(i, 1), , xlValues, xlWhole, , , False)
    If Not f Is Nothing Then
      sh3.Range("A" & k).Resize(1, 2).Value = Array(a(i, 1), a(i, 2))
      k = k + 1
      sh2.Range("A1").AutoFilter 1, a(i, 1)
      sh2.AutoFilter.Range.Range("B2:B" & lr & ",D2:E" & lr).Copy sh3.Range("B" & k)
      k = sh3.Range("B" & Rows.Count).End(3).Row + 2
    End If
  Next
  
  If sh2.AutoFilterMode Then sh2.AutoFilterMode = False
  Application.ScreenUpdating = True
End Sub

 

[shynot]

Hi Dante,

With a bit of tweaking, it works a treat! Thanks so much for the help

 

[DanteAmor]

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