Excel VBA: Generating a new array from an existing array, but skipping specific strings

Question

Here is what I am trying to do in Excel.

Simply put, I am trying to take a 2D array, (1) convert it into a 1D array, (2) cycle through the 1D array, (3) copy any values that aren't specific strings to a new array, and (4) then write that new, trimmed 1D array to a specific column.

More complexly put, I am trying to take two 2D arrays, convert them both into matched 1D arrays, cycle through them both, but only copy the contents based on one of the arrays into two different arrays, and then write the new arrays into two different columns (didn't explain that all that well...)

With my rudimentray VBA knowledge, cobbled together from what I can find online, I have somehow managed to write some code that accomplishes (1), (2), and (4). The issues I am having is with (3). I can not seem to get it to skip over the specific cells.

Does anyone have any advice for how this can be done?

Below is the code I cobbled together. Be forewarned, this is the first code I have written, so I am guessing that there are far simpler and more elegant ways to do this; I did what worked for me. Any advice on tweaks would be greatly appreciated!

Sub Calculating()

'Transforming 2D Arrays into 1D Arrays

'Defining the arrays
Dim InputNameArray() As Variant 'Input Names (strings)
Dim InputValueArray() As Variant 'Input Values (numbers)
Dim InputArrayR As Long 'Old Array Row
Dim InputArrayC As Long 'Old Array Column

Dim OldArrayP As Long 'Old Array Position

Dim OldNameArray() As Variant 'One Dimensional Names
Dim OldValueArray() As Variant 'One Dimensional Values

InputNameArray = Range("B3:M10")
InputValueArray = Range("B27:M34")

OldArrayP = 0 'Old Array One Dimensional Position

For InputArrayR = 1 To UBound(InputNameArray, 1)
    For InputArrayC = 1 To UBound(InputNameArray, 2)

        ReDim Preserve OldNameArray(0 To OldArrayP)
        OldNameArray(OldArrayP) = InputNameArray(InputArrayR, InputArrayC)

        ReDim Preserve OldValueArray(0 To OldArrayP)
        OldValueArray(OldArrayP) = InputValueArray(InputArrayR, InputArrayC)

        Debug.Print OldArrayP; OldNameArray(OldArrayP), OldValueArray(OldArrayP)

        OldArrayP = OldArrayP + 1

    Next InputArrayC
Next InputArrayR



'Scanning through 1D Arrays to Eliminate Specific Values

'Defining New Arrays

Dim NewNameArray() As Variant 'New Name Array (Strings)
Dim NewValueArray() As Variant 'New Value Array (Numbers)

Dim NewArrayP As Long 'New Array Position
Dim OldArrayPosition As Long 'Old Array Position

NewArrayP = 0

For OldArrayPosition = LBound(OldNameArray) To UBound(OldNameArray)
    If OldNameArray(OldArrayPosition) <> "Blank" Or OldNameArray(OldArrayPosition) <> "Standard-100" Or OldNameArray(OldArrayPosition) <> "Standard-50" Or OldNameArray(OldArrayPosition) <> "Standard-25" Or OldNameArray(OldArrayPosition) <> "Standard-12.5" Or OldNameArray(OldArrayPosition) <> "Standard-6.25" Or OldNameArray(OldArrayPosition) <> "Standard-3.125" Or OldNameArray(OldArrayPosition) <> "Standard-1.5625" Or OldNameArray(OldArrayPosition) <> "Standard-0.7825" Then
        ReDim Preserve NewNameArray(0 To NewArrayP)
            NewNameArray(NewArrayP) = OldNameArray(OldArrayPosition)
        ReDim Preserve NewValueArray(0 To NewArrayP)
            NewValueArray(NewArrayP) = OldValueArray(OldArrayPosition)

        Debug.Print OldArrayPosition, OldNameArray(OldArrayPosition), OldValueArray(OldArrayPosition)
        Debug.Print NewArrayP, NewNameArray(NewArrayP), NewValueArray(NewArrayP)

        NewArrayP = NewArrayP + 1
    End If
Next OldArrayPosition

'Outputing Values

'Defining Variables

Dim OutputPosition As Long 'Output Array Position
Dim OutputRow As Long 'Output Row

OutputRow = 3

For OutputPosition = LBound(NewNameArray) To UBound(NewNameArray)
    Cells(OutputRow, "O").Value = NewNameArray(OutputPosition)
    Cells(OutputRow, "Q").Value = NewValueArray(OutputPosition)

    Debug.Print OutputRow, OutputPosition, NewNameArray(OutputPosition), NewValueArray(OutputPosition)

    OutputRow = OutputRow + 1
Next OutputPosition


'Cleaning Up

Erase InputNameArray
Erase InputValueArray
Erase OldNameArray
Erase OldValueArray
Erase NewNameArray
Erase NewValueArray

End Sub

Whenever you're working with dynamic data, I recommend using collections or dictionaries. http://msdn.microsoft.com/en-us/library/a1y8b3b3%28v=vs.90%29.aspx — CodeJockey, Jun 12 '14 at 18:01

score 0 · Answer 1 · edited May 23 '17 at 10:25

Your code is quite logical. The bug is the use of Or in the If statement; switch those to And and the code should work.

You can avoid manipulating all those arrays, perhaps something like the below. I named the input ranges to make it a little easier to resize them. If you like that, you might want to do the same for the output range.

Although I know it's quite standard VBA practice, I really, really dislike exceptions as flow control, hence the long-winded Exists method; you might prefer the alternatives mentioned here. (It will make no difference in performance for such small sets of data).

Finally, I've been a little lazy. There are plenty of "best practice" resources online that you might like to have a read through, for example this.

Option Explicit

Private Function Exists(ByRef col As Collection, ByRef key As Variant) As Boolean
  Dim Iter As Long

  For Iter = 1 To col.Count
    If key = col.Item(Iter) Then
      Exists = True
      Exit Function
    End If
  Next Iter

  Exists = False
End Function

Sub Calculating()
  Dim NamesToSkip As Collection

  Dim NameArray As Range
  Dim ValueArray As Range
  Dim OutputRange As Range
  Dim Rows As Long
  Dim Columns As Long
  Dim Row As Long
  Dim Column As Long
  Dim Iter As Long

  Set NamesToSkip = New Collection
  NamesToSkip.Add "Blank"
  NamesToSkip.Add "Standard-100"
  NamesToSkip.Add "Standard-50"
  NamesToSkip.Add "Standard-25"
  NamesToSkip.Add "Standard-12.5"
  NamesToSkip.Add "Standard-6.25"
  NamesToSkip.Add "Standard-3.125"
  NamesToSkip.Add "Standard-1.5625"
  NamesToSkip.Add "Standard-0.7825"

  Set NameArray = Range("InputNames")
  Set ValueArray = Range("InputValues")
  Set OutputRange = Range("O3")

  Rows = NameArray.Rows.Count
  Columns = NameArray.Columns.Count

  If Rows <> ValueArray.Rows.Count Or Columns <> ValueArray.Columns.Count Then
    Err.Raise vbObjectError + 513, "Calculating()", "Mismatched sizes of input arrays"
  End If

  Iter = 1
  For Row = 1 To Rows
    For Column = 1 To Columns
      If Not Exists(NamesToSkip, NameArray.Cells(Row, Column)) Then
        OutputRange.Cells(Iter, 1) = NameArray.Cells(Row, Column)
        OutputRange.Cells(Iter, 3) = ValueArray.Cells(Row, Column)
        Iter = Iter + 1
      End If
    Next Column
  Next Row

  Set NamesToSkip = Nothing
End Sub

Excel VBA: Generating a new array from an existing array, but skipping specific strings

1 Answers1