Create a dynamic 2-D array, if a value matches to a column

Raghav Chamadiya

New Member
Joined
May 31, 2020
Messages
13
Office Version
  1. 2016
Platform
  1. Windows
Hi, so I am trying to create a dynamic VBA array, with 3 columns, and dynamic rows. This is my code so far:
VBA Code:
Sub Test4()

Application.DisplayAlerts = False
Application.ScreenUpdating = False
Application.EnableEvents = False
Application.AutomationSecurity = msoAutomationSecurityLow

Dim nwb As Workbook
Set nwb = Workbooks.Open("DB location")

Dim arr() As Variant
Dim strColumn As String
Dim strColumn2 As String

strColumn = "F"
strColumn2 = "C"
strColumn3 = "E"

Dim iVal As Integer
iVal = Application.WorksheetFunction.CountIf(nwb.Sheets("Data").Range("F2:F8"), "DS packaging")

ReDim arr(2, iVal)
With nwb.Sheets("Data")
lngLastRow = .Cells(.rows.Count, strColumn).End(xlUp).row
    For i = 0 To iVal - 1
    For lngRow = 2 To lngLastRow
            If .Cells(lngRow, strColumn).Value = "DS packaging" Then
                ReDim Preserve arr(2, i)
                arr(0, i) = .Cells(lngRow, strColumn).Value
                arr(1, i) = CDate(.Cells(lngRow, strColumn2).Value)
                arr(2, i) = CDate(.Cells(lngRow, strColumn3).Value)
            End If
    Next lngRow
    Next i
End With    
nwb.SaveAs Filename:="DB location"

MsgBox (arr(1, 1))
MsgBox (MatrixJoin(arr))

End Sub

And this is the database:
1606377510828.png


Ideally code should, search for DS packaging in the F column, and create an array, with 1st column as DS packaging, 2nd column as corresponding, Start Date, and 3rd column as corresponding End Date.

I know I have inverted rows and columns while defining array, and writing loop, thats because I read somewhere I can only preserve the last dimension in an array.
The current output from my code is:
1606377707404.png

The Matrix Join function simply, creates this matrix type view of the array:
VBA Code:
Function MatrixJoin(M As Variant, Optional delim1 As String = vbTab, Optional delim2 As String = vbCrLf) As String
    Dim i As Long, j As Long
    Dim row As Variant, rows As Variant

    ReDim rows(LBound(M, 1) To UBound(M, 1))
    ReDim row(LBound(M, 2) To UBound(M, 2))

    For i = LBound(M, 1) To UBound(M, 1)
        For j = LBound(M, 2) To UBound(M, 2)
            row(j) = M(i, j)
        Next j
        rows(i) = Join(row, delim1)
    Next i
    MatrixJoin = Join(rows, delim2)
End Function

Please help. I am stuck on this from way too long.
 

Some videos you may like

Excel Facts

Lock one reference in a formula
Need 1 part of a formula to always point to the same range? use $ signs: $V$2:$Z$99 will always point to V2:Z99, even after copying

Peter_SSs

MrExcel MVP, Moderator
Joined
May 28, 2005
Messages
48,400
Office Version
  1. 365
Platform
  1. Windows
First a couple of general suggestions:
  • Investigate XL2BB for providing sample data to make it easier for helpers by not having to manually type out sample data to test with.
  • You have shown the current output of your code which is not what you want but you have not shown the output that you do want.
Ideally code should, search for DS packaging in the F column, and create an array, with 1st column as DS packaging, 2nd column as corresponding, Start Date, and 3rd column as corresponding End Date.
So, I have not studied your code but attempted what I think you are saying here, starting from scratch. See if this is headed in the right direction.

VBA Code:
Sub Make_Array()
  Dim aRws As Variant, arr As Variant

  With Range("C1", Range("F" & Rows.Count).End(xlUp))
    aRws = Filter(Application.Transpose(Evaluate(Replace("if(len(#),if(#=""DS packaging"",row(#),""x""),""x"")", "#", .Columns(4).Address))), "x", False)
    arr = Application.Index(.Cells.Value2, Application.Transpose(aRws), Array(4, 1, 3))
  End With
  With Range("J2").Resize(UBound(arr, 1), UBound(arr, 2))
    .Columns(2).Resize(, 2).NumberFormat = "d-mmm-yy"
    .Value = arr
  End With
End Sub

Here is my sample data and result of code:

Raghav Chamadiya.xlsm
CDEFGHIJKL
1
210-Jan-2016-Jan-20DS packagingDS packaging10-Jan-2016-Jan-20
31-Jan-2025-Jan-20OtherDS packaging29-Jun-2028-Aug-20
45-Feb-204-Apr-20DS packaging19-Jun-207-Aug-20
529-Jun-2028-Aug-20DS packaging
619-Jun-207-Aug-20DS packaging
7
Sheet1
 
Solution

Raghav Chamadiya

New Member
Joined
May 31, 2020
Messages
13
Office Version
  1. 2016
Platform
  1. Windows
Thank you so much Peter, I will follow the points next time I post question here, thanks so much again.
 

Watch MrExcel Video

Forum statistics

Threads
1,127,407
Messages
5,624,587
Members
416,036
Latest member
eloisa manzanarez

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