Transfer Data based off a criteria to certain Column

[ItalianPlatinum]

I need some help to transfer my data to specific columns on my destination sheet. The ability to modify it if it changes I have a line of code that transfers based off a criteria but now to specific columns adds a bit of complexity for me. See for example the below.

Out of memory Run-time 7 Transferring data

I am running into a runtime error trying to transfer data using VBA I used before so I know it works. But when facing a larger data set it is kicking out the below. is there any root cause / solution I can entertain? If Application.WorksheetFunction.CountIf(rng, ">1") > 0 Then 'transfer...

www.mrexcel.com

Source data - the amount of rows may change but always starts on row 11:

Book2
	A	B	C	D	E	F	G	H	I	J	K	L	M	N	O	P	Q
1
2
3
4
5
6
7
8
9
10
11	Concatenate	Date	Account	Indicator	Group	Currency	Price	Unit Holders	Value	Factor	Average	Total Assets	Total Liabilities	Rate 1	Rate 1 %	Rate 2	Rate 2 %
12	AAAF	1/10/2025	AAA	F	1	USD	$10	1000	$100	0.0001	$10	100	$50	0.005	10%	0.095	90%
Source

Destination - With a header starts on row 2. Should look like this:

Book2
	A	B	C	D	E	F	G	H	I	J	K	L	M	N	O	P	Q	R
1	Date	Main Account	Unique ID	Indicator	Main Account Group	Currency	Price	Unit Holders	Value	Factor	Pre Price	Average	Total Assets	Total Liabilities	Rate 1	Rate 1 %	Rate 2	Rate 2 %
2		AAA		F	1	USD	10	1000	100	0.0001		10	100	50	0.005	0.1	0.095	0.9
3
Destination

The data must transfer based off the criteria in column D = F. As there will also be other indicators of AZ on it that I do not want to bring over. Thanks in advance - any help is always appreciated. This is a mockup by actual data is over 300 rows if it matters.

 

[DanteAmor]

The ability to modify it if it changes I have a line of code that transfers based off a criteria but now to specific columns adds a bit of complexity for me. See for example the below.

Since some of the names in the headers are different, the simplest thing to do is to route the source column to the destination column.
Array 'a' is the source and array 'b' is the one that receives the data.
Review the code and if you have any questions ask me.

If the headers could be the same then the code could be shortened.

Sub TransferData()
  Dim a As Variant, b As Variant
  Dim i As Long
  
  a = Sheets("Source").Range("A12:Q" & Sheets("Source").Range("A" & Rows.Count).End(3).Row).Value
  ReDim b(1 To UBound(a, 1), 1 To 18)
  
  For i = 1 To UBound(a, 1)
    If a(i, 4) = "F" Then
      b(i, 1) = a(i, 2)   'date
      b(i, 2) = a(i, 3)   'acc
      b(i, 3) = ""        'unique id
      b(i, 4) = a(i, 4)   'Indicator
      b(i, 5) = a(i, 5)   'group
      b(i, 6) = a(i, 6)   'currency
      b(i, 7) = a(i, 7)   'price
      b(i, 8) = a(i, 8)   'unit
      b(i, 9) = a(i, 9)   'value
      b(i, 10) = a(i, 10) 'factor
      b(i, 11) = ""       'pre price
      b(i, 12) = a(i, 11) 'average
      b(i, 13) = a(i, 12) 'tot assets
      b(i, 14) = a(i, 13) 'tot lia
      b(i, 15) = a(i, 14) 'rate 1
      b(i, 16) = a(i, 15) 'rate 1%
      b(i, 17) = a(i, 16) 'rate 2
      b(i, 18) = a(i, 17) 'rate 2%
    End If
  Next
  
  With Sheets("Destination")
    .Rows("2:" & Rows.Count).ClearContents
    .Range("A2").Resize(UBound(b, 1), UBound(b, 2)).Value = b
  End With
End Sub

 

[ItalianPlatinum]

Unfortunately they cannot - I will give that a go and let you know. Thank you!

 

[DanteAmor]

Unfortunately they cannot

What? The headers?

I will give that a go and let you know.

What are you going to try? the macro?

Ok, try the macro, the result should be immediate.

 

[ItalianPlatinum]

Yeah I can't get the header names to match. One comes from a hard coded ledger systems so I can't control the source. And the destination is how its delivered to downstream consumers so I require it that way. So they are different unfortunately.

On the macro I noticed that the F criteria can be scattered. For example rows 11-100 could be F, and 101-200 AZ, then 201-300 again F. What I noticed is that second set 201-300 F go on the destination not after the next open row but the equivalent row from where it came from. So what I end up with is a block of like 100 rows blank then the 2nd set of F criteria appears. Any way to have it be on the destination all together?

 

[DanteAmor]

So what I end up with is a block of like 100 rows blank then the 2nd set of F criteria appears. Any way to have it be on the destination all together?

Try this:

Sub TransferData()
  Dim a As Variant, b As Variant
  Dim i As Long, k As Long
  
  a = Sheets("Source").Range("A12:Q" & Sheets("Source").Range("A" & Rows.Count).End(3).Row).Value
  ReDim b(1 To UBound(a, 1), 1 To 18)
  
  For i = 1 To UBound(a, 1)
    If a(i, 4) = "F" Then
      k = k + 1
      b(k, 1) = a(i, 2)   'date
      b(k, 2) = a(i, 3)   'acc
      b(k, 3) = ""        'unique id
      b(k, 4) = a(i, 4)   'Indicator
      b(k, 5) = a(i, 5)   'group
      b(k, 6) = a(i, 6)   'currency
      b(k, 7) = a(i, 7)   'price
      b(k, 8) = a(i, 8)   'unit
      b(k, 9) = a(i, 9)   'value
      b(k, 10) = a(i, 10) 'factor
      b(k, 11) = ""       'pre price
      b(k, 12) = a(i, 11) 'average
      b(k, 13) = a(i, 12) 'tot assets
      b(k, 14) = a(i, 13) 'tot lia
      b(k, 15) = a(i, 14) 'rate 1
      b(k, 16) = a(i, 15) 'rate 1%
      b(k, 17) = a(i, 16) 'rate 2
      b(k, 18) = a(i, 17) 'rate 2%
    End If
  Next
  
  With Sheets("Destination")
    .Rows("2:" & Rows.Count).ClearContents
    .Range("A2").Resize(UBound(b, 1), UBound(b, 2)).Value = b
  End With
End Sub

 

[ItalianPlatinum]

While testing could there be a minor variation. If a cell value equals zero can it bring over "" and if not zero the actual record? For example on the source if there is a zero value I don't want zero coming over need the field to be blank only if there is a non zero record I want to see it. I noticed it as I was testing so sorry it didn't make the first iteration

 

[ItalianPlatinum]

I should add that applies to all except this line

b(k, 5) = a(i, 5)

 

[DanteAmor]

f a cell value equals zero can it bring over ""

Try:

Sub TransferData()
  Dim a As Variant, b As Variant
  Dim i As Long, k As Long
  
  a = Sheets("Source").Range("A12:Q" & Sheets("Source").Range("A" & Rows.Count).End(3).Row).Value
  ReDim b(1 To UBound(a, 1), 1 To 18)
  
  For i = 1 To UBound(a, 1)
    If a(i, 4) = "F" Then
      k = k + 1
      b(k, 1) = IIf(a(i, 2) = 0, "", a(i, 2))     'date
      b(k, 2) = IIf(a(i, 3) = 0, "", a(i, 3))     'acc
      b(k, 3) = ""                                'unique id
      b(k, 4) = IIf(a(i, 4) = 0, "", a(i, 4))     'Indicator
      b(k, 5) = a(i, 5)                           'group
      b(k, 6) = IIf(a(i, 6) = 0, "", a(i, 6))     'currency
      b(k, 7) = IIf(a(i, 7) = 0, "", a(i, 7))     'price
      b(k, 8) = IIf(a(i, 8) = 0, "", a(i, 8))     'unit
      b(k, 9) = IIf(a(i, 9) = 0, "", a(i, 9))     'value
      b(k, 10) = IIf(a(i, 10) = 0, "", a(i, 10))  'factor
      b(k, 11) = ""                               'pre price
      b(k, 12) = IIf(a(i, 11) = 0, "", a(i, 11))  'average
      b(k, 13) = IIf(a(i, 12) = 0, "", a(i, 12))  'tot assets
      b(k, 14) = IIf(a(i, 13) = 0, "", a(i, 13))  'tot lia
      b(k, 15) = IIf(a(i, 14) = 0, "", a(i, 14))  'rate 1
      b(k, 16) = IIf(a(i, 15) = 0, "", a(i, 15))  'rate 1%
      b(k, 17) = IIf(a(i, 16) = 0, "", a(i, 16))  'rate 2
      b(k, 18) = IIf(a(i, 17) = 0, "", a(i, 17))  'rate 2%
    End If
  Next
  
  With Sheets("Destination")
    .Rows("2:" & Rows.Count).ClearContents
    .Range("A2").Resize(UBound(b, 1), UBound(b, 2)).Value = b
  End With
End Sub

 

[ItalianPlatinum]

wow works great. Nice job. Going to test tomorrow on big data set when I get back to work