My array fails to replace and offset values VBA

Question

MyFile = Dir(MyFolder)
    Do While MyFile <> ""
        Application.StatusBar = "Opening" & MyFile
        Set wbk = Workbooks.Open(MyFolder & MyFile, True, True)
        bFound = False
        For Each ws In wbk.Sheets
            If ws.Name = "Sheet 1" Then
                Range("B2").Select    'This gives us the first cell
                Do Until IsEmpty(ActiveCell)
                    For i = LBound(arr, 1) To UBound(arr, 1)
                        For j = LBound(arr, 2) To UBound(arr, 2)
                            If arr(i, j) <> "" And arr(i, j) <> ActiveCell.Value Then
                                For k = UBound(arr, 2) To j + 1 Step -1
                                    arr(k, i) = arr(k - 1, i)
                                Next k
                                arr(i, j) = ActiveCell.Value
                            End If
                            If arr(i, j) = "" Then
                                arr(i, j) = ActiveCell.Value
                                ActiveCell.Offset(1, 0).Select
                            End If
                            If arr(i, j) = ActiveCell.Value Then
                                ActiveCell.Offset(1, 0).Select
                            End If
                            If ActiveCell.Value = "" Then
                                Exit For
                            End If                                
                        Next j
                        If ActiveCell.Value = "" Then
                                Exit For
                        End If
                    Next i
                    Loop
            End If
        Next
    Loop

As you can see in the image I have an array of 4 elements, I got these elements into the array by iterating through the second column of a worksheet called "Sheet 1" from a workbook called "food.xlsx" in a folder that the user choses by selection. after the array places every element from column 2 of sheet "Sheet 1" and then places these elements into column 1 of itself, our array looks like the following image...

We then move on to the next workbook called "food2.xlsx" which is located in the same folder. We look at column 2 of food2.xlsx. Column 2 of food2.xlsx has the exact same values at the exact same rows as column 2 of food.xlsx. The only difference is that in row 3 of column 2 in food2.xlsx, instead of having a value of "chocolate", there is a value of "vanilla". What am I trying to do is place "vanilla" in the location of the array where "chocolate" is currently located, this would be at arr(1,3). Then what I want is to push "chocolate" and every other value under it down one spot. So the array should end up like..

The part of the code that is NOT doing its job is the if statement that starts with "If arr(i, j) <> "" And arr(i, j) <> ActiveCell.Value Then"

IMPORTANT: I need this to work for any new encountered value, not just vanilla

Answer 1

Unrelated note: I prefer the FileSystemObject API over the VBA Dir function; which you can use by adding a reference (Tools -> References...) to the Microsoft Scripting Runtime library.

I would suggest using a disconnected ADO recordset. Recordsets are commonly associated with pulling data from databases or other data sources; but we can construct and fill our own, and use the recordset's built-in sorting capabilities. This frees us from worrying about shifting elements back and forth within the array, or even from the proper position in which to insert the new element.

Add a reference (Tools -> References...) to Microsoft ActiveX Data Objects; choose the latest version -- usually 6.1.

Then, you could have code like the following:

' Define the shape of the recordset
Dim rs As New ADODB.Recordset
rs.Fields.Append "Entry", adVarChar, 100
rs.Fields.Append "FileIndex", adTinyInt
rs.Fields.Append "RowIndex", adTinyInt
rs.Open

' Loop over the files, and populate the recordset
MyFile = Dir(MyFolder)
Do While MyFile <> ""
    Dim fileIndex As Integer

    Application.StatusBar = "Opening" & MyFile
    Set wbk = Workbooks.Open(MyFolder & MyFile, True, True)

    Dim data As Variant
    data = wbk.Worksheets("Sheet 1").UsedRange.Columns(2).Value

    Dim ubnd As Integer
    ubnd = UBound(data, 1)

    Dim rowIndex As Integer
    For rowIndex = 1 To ubnd
        Dim entry As String
        entry = data(rowIndex, 1)
        
        rs.Find "Entry='" & entry & "'"
        If rs.BOF Or rs.EOF Then ' record hasn't been found or recordset is empty
            rs.AddNew _
                Array("Entry", "RowIndex", "FileIndex"), _
                Array(entry, rowIndex, fileIndex)
            rs.Update
        End If
        rs.MoveFirst
    Next
    
    wbk.Close
    MyFile = Dir
    fileIndex = fileIndex + 1
Loop

' Specify the sort order, first by the row within the file, then by the order in which
' the file was processed
rs.Sort = "RowIndex,FileIndex"

' Iterate over the data, and print it to the Immediate pane
rs.MoveFirst
Do Until rs.EOF
    Debug.Print rs("Entry")
Loop

Note that the elements are sorted first by the order in which they appear in their respective files, then by the order in which the file was processed.

---

Links

Excel

• Workbook object — Worksheets property and collection, Close method
• Worksheet object — UsedRange property
• Range object — Columns and Value properties

VBA

• Dir, UBound functions

ADO

• Recordset object
  • Fields property and collection, Fields.Append method
  • BOF / EOF properties
  • Find, AddNew, Update, MoveFirst methods
  • Sort property

Answer 2

Since you're determined to use an array, here's an example of how to shift "rows" down to create an empty slot at a specified index:

Sub Tester()
    Dim arr
    arr = Range("A1:E10").Value  'get some data
    
    ShuffleDown arr, 3 'insert a blank row at index 3
    
    Range("G1:K10").Value = arr  'show the modified content
    
End Sub

'Create a blank row at InsertRowIndex in a 2-D array, by shifting content down
'Does not warn about content being lost from the last "row"
'  of the array if there's already content there !
Sub ShuffleDown(ByRef arr, InsertRowIndex As Long)
    Dim rw As Long, col As Long
    For rw = UBound(arr, 1) To InsertRowIndex Step -1
        For col = LBound(arr, 2) To UBound(arr, 2)
            If rw > InsertRowIndex Then
                arr(rw, col) = arr(rw - 1, col)
            Else
                arr(rw, col) = ""
            End If
        Next col
    Next rw
End Sub