Extract data from an array and populate new array but only keep certain columns

[SharmaAntriksh]

Name	Serial Number	Date	Price	Address	Comments
A	1	1/1/2019	123	abc	xyz
B	2	1/1/2019	123	abc	xyz
A	3	1/1/2019	123	abc	xyz
C	4	1/1/2019	123	abc	xyz

<tbody>
</tbody>

i have data that looks like this, i am trying to load this into an array and populate a new array with the data where name is "A" i want the new array to only have the columns "Name", "Price", and "Comments". i am able to extract the rows with the help of below code but i am not sure how to keep only the required columns while the loop is running

Sub WorkingWithArrays()
    Dim OriAry() As Variant 'Will store original data
    Dim NewAry() As Variant 'will have the data after satisfying a condition
    Dim i As Integer, Counter As Integer, k As Integer
    
    OriAry = Sheet2.Range("A1:F5")
    
    For i = LBound(OriAry, 1) To UBound(OriAry, 1)
        If OriAry(i, 1) = "A" Then
            Counter = Counter + 1


            ReDim Preserve NewAry(LBound(OriAry, 2) To UBound(OriAry, 2), 1 To Counter)
            For k = LBound(OriAry, 2) To UBound(OriAry, 2)
                NewAry(k, Counter) = OriAry(i, k)
            Next k
        End If
    Next i
    
    Sheet3.Range("A2", Sheet3.Range("A2").Offset(Counter - 1, UBound(NewAry, 1) - 1)) = Application.Transpose(NewAry)
End Sub

 

[Legacy 436357]

This can be done with index/ match formulas

Excel Workbook
	B	C	D	E	F	G
2	Name	email	Contact No.	Data 1	Data 2	Data 3
3	John	john@gmail.com	555-555-5555	red	box	gadget
4	Mary	mary@gmail.com	555-555-1234
5	Susan	susan@gmail.com	444-444-4444
Sheet1

Sheet2

	C	D	E	F	G	H
3	Name	email	Contact No.	Data 1	Data 2	Data 3
4	Susan	susan@gmail.com	444-444-4444	0	0	0
5	Mary	mary@gmail.com	555-555-1234	0	0	0
6	Mary	mary@gmail.com	555-555-1234	0	0	0
7	John	john@gmail.com	555-555-5555	red	box	gadget

Spreadsheet Formulas

Cell Formula D4 {=IFERROR(INDEX(Sheet1!C$3:C$500,MATCH($C4,Sheet1!$B$3:$B$500,0)),"")} E4 {=IFERROR(INDEX(Sheet1!D$3:D$500,MATCH($C4,Sheet1!$B$3:$B$500,0)),"")} F4 {=IFERROR(INDEX(Sheet1!E$3:E$500,MATCH($C4,Sheet1!$B$3:$B$500,0)),"")} G4 {=IFERROR(INDEX(Sheet1!F$3:F$500,MATCH($C4,Sheet1!$B$3:$B$500,0)),"")} H4 {=IFERROR(INDEX(Sheet1!G$3:G$500,MATCH($C4,Sheet1!$B$3:$B$500,0)),"")} D5 {=IFERROR(INDEX(Sheet1!C$3:C$500,MATCH($C5,Sheet1!$B$3:$B$500,0)),"")} E5 {=IFERROR(INDEX(Sheet1!D$3:D$500,MATCH($C5,Sheet1!$B$3:$B$500,0)),"")} F5 {=IFERROR(INDEX(Sheet1!E$3:E$500,MATCH($C5,Sheet1!$B$3:$B$500,0)),"")} G5 {=IFERROR(INDEX(Sheet1!F$3:F$500,MATCH($C5,Sheet1!$B$3:$B$500,0)),"")} H5 {=IFERROR(INDEX(Sheet1!G$3:G$500,MATCH($C5,Sheet1!$B$3:$B$500,0)),"")} D6 {=IFERROR(INDEX(Sheet1!C$3:C$500,MATCH($C6,Sheet1!$B$3:$B$500,0)),"")} E6 {=IFERROR(INDEX(Sheet1!D$3:D$500,MATCH($C6,Sheet1!$B$3:$B$500,0)),"")} F6 {=IFERROR(INDEX(Sheet1!E$3:E$500,MATCH($C6,Sheet1!$B$3:$B$500,0)),"")} G6 {=IFERROR(INDEX(Sheet1!F$3:F$500,MATCH($C6,Sheet1!$B$3:$B$500,0)),"")} H6 {=IFERROR(INDEX(Sheet1!G$3:G$500,MATCH($C6,Sheet1!$B$3:$B$500,0)),"")} D7 {=IFERROR(INDEX(Sheet1!C$3:C$500,MATCH($C7,Sheet1!$B$3:$B$500,0)),"")} E7 {=IFERROR(INDEX(Sheet1!D$3:D$500,MATCH($C7,Sheet1!$B$3:$B$500,0)),"")} F7 {=IFERROR(INDEX(Sheet1!E$3:E$500,MATCH($C7,Sheet1!$B$3:$B$500,0)),"")} G7 {=IFERROR(INDEX(Sheet1!F$3:F$500,MATCH($C7,Sheet1!$B$3:$B$500,0)),"")} H7 {=IFERROR(INDEX(Sheet1!G$3:G$500,MATCH($C7,Sheet1!$B$3:$B$500,0)),"")}

Formula Array: Produce enclosing { } by entering formula with CTRL+SHIFT+ENTER!

 

[SharmaAntriksh]

Hey, thank you, but i need to implement a VBA solution only as the data in future will be coming from multiple excel files so i want user to not worry about applying formulas. Also anyone who comments after this please note that i only want suggestions/help related only to VBA code and not for Excel functions.

 

[MickG]

Perhaps something like this:-

[COLOR="Navy"]Sub[/COLOR] MG07Nov25
[COLOR="Navy"]Dim[/COLOR] Ray [COLOR="Navy"]As[/COLOR] Variant, n [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long,[/COLOR] c [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long[/COLOR]
Ray = Sheets("Sheet2").Range("A1").CurrentRegion.Resize(, 6)
ReDim nRay(1 To UBound(Ray, 1), 1 To 3)
[COLOR="Navy"]For[/COLOR] n = 1 To UBound(Ray, 1)
    [COLOR="Navy"]If[/COLOR] Ray(n, 1) = "A" Or n = 1 [COLOR="Navy"]Then[/COLOR]
        c = c + 1
        nRay(c, 1) = Ray(n, 1)
        nRay(c, 2) = Ray(n, 4)
        nRay(c, 3) = Ray(n, 6)
    [COLOR="Navy"]End[/COLOR] If
[COLOR="Navy"]Next[/COLOR] n
 Sheets("Sheet3").Range("A1").Resize(c, 3) = nRay

[COLOR="Navy"]End[/COLOR] [COLOR="Navy"]Sub[/COLOR]

Regards Mick