Is it possible to get the row positions in a large table in excel without performing a loop?
What I am trying to do is to click on a particular ID, and then the last 3 records from the same ID will be shown in UI.
I am beginner in programming and have no idea how to do this aside from looping method (which is very resource and memory-intensive considering we are looping a large and growing table of 100k rows in every single click from user).
For example: If user is clicking "A123" then we know that their row positions are : 5, 8 , 10
Same as CDP1802 posted but faster finding of last 3 rows.
Sub FilteredAdvanced()
Const nValues As Long = 3 'amount of rows you want to find from the end
Dim ar() As Long
ReDim ar(nValues - 1) As Long
' apply filter
With Sheet1
.AutoFilterMode = False
.UsedRange.AutoFilter 1, "A123"
Dim rng As Range
Set rng = .UsedRange.Columns(1).SpecialCells(xlCellTypeVisible)
.UsedRange.AutoFilter 'remove filter
End With
Dim n As Long
n = nValues - 1
Dim iArea As Long
For iArea = rng.Areas.Count To 1 Step -1
Dim iRow As Long
For iRow = rng.Areas(iArea).Rows.Count To 1 Step -1
ar(n) = rng.Areas(iArea).Rows(iRow).Row
n = n - 1
If n < 0 Then Exit For
Next iRow
If n < 0 Then Exit For
Next iArea
Dim j As Long
For j = 0 To nValues - 1
Debug.Print ar(j)
Next
End Sub
Looping filtered a list
Option Explicit
Sub Filtered()
Dim rng as Range, ID As Range, a As Range
Dim ar(2) As Long, i As Integer, j As Integer
' apply filter
With Sheet1
.AutoFilterMode = False
.UsedRange.AutoFilter 1, "A123"
Set rng = .UsedRange.Columns(1).SpecialCells(xlCellTypeVisible)
End With
' count
For Each a In rng.Areas
For Each ID In a.Cells
If ID.Row > 1 Then
i = (i + 1) Mod 3
ar(i) = ID.Row
End If
Next
Next
For j = 1 To 3
Debug.Print ar((j + i) Mod 3)
Next
End Sub
Related
I am trying to do a loop but I'm a little stuck.
Sub Macro()
Range("A392: A401").Value = Range("N2")
Range("A402: A411").Value = Range("N3")
Range("A412: A421").Value = Range("N4")
Range("A422: A431").Value = Range("N5")
....
I need to repeat this logic ( On column A to set a value for each 10 rows) this value will be from Column N from 1 to 1 until it finds an empty row ...
I'm not being able to do the loop with these multiples conditions, would you please help me ?
Thanks a lot!
Range.Offset is a great method to manipulate ranges. Using it, we can automate the ranges to move down the sheet with each loop.
Sub Macro()
Dim i As Long
While Range("N2").Offset(i) <> ""
'Offset will shift N2 down by one each loop
'Offset will shift the 10 cell range down by 10 on each loop
Range("A392: A401").Offset(i * 10).Value = Range("N2").Offset(i)
i = i + 1
Wend
End Sub
I'm not quite sure what's your actual intention:
Repeat all values in column N2:N5 10 times and append the whole data block to the first free cell in column A.
Repeat all non-empty values in column N 10 times and write them to a fixed target starting with cell A392.
In both cases you can prefill an array and write it to the defined target in column A. Looping through an array has some speed advantages whereas looping through a range by means of VBA can be time consuming.
The direct (untested) copying of whole blocks as shown by #Toddleson can improve this behaviour, depending on total range sizes.
Case 1
Sub Example1()
Const RowsCount As Long = 10
With Sheet1 ' << change to your project's sheet (Code)Name
'get values to repeat & count them
Dim vals: vals = .Range("N2:N5")
Dim cnt As Long: cnt = UBound(vals)
'provide for 1-based 2-dim results array
Dim results
ReDim results(1 To RowsCount * cnt, 1 To 1)
'fill array with repeated values
Dim i As Long, j As Long
For i = 1 To cnt
For j = 1 To RowsCount
results((i - 1) * RowsCount + j, 1) = vals(i, 1)
Next j
Next i
'append above data block
Dim nxtRow As Long
nxtRow = .Range("A" & .Rows.Count).End(xlUp).Row + 1
.Range("A" & nxtRow).Resize(UBound(results), 1) = results
End With
End Sub
Case 2
Sub Example2()
Const RowsCount As Long = 10
With Sheet1 ' << change to your project's sheet (Code)Name
'get values to repeat & count them
Dim lastRow As Long
lastRow = .Range("N" & .Rows.Count).End(xlUp).Row
Dim vals: vals = .Range("N2:N" & lastRow)
Dim ValsCount As Long: ValsCount = UBound(vals)
'provide for 1-based 2-dim results array
Dim results
ReDim results(1 To RowsCount * ValsCount, 1 To 1)
'fill array with repeated values
Dim i As Long, j As Long, ii As Long
For i = 1 To ValsCount
If Len(vals(i, 1)) > 0 Then ' check if non-empty value in column N
ii = ii + 1
For j = 1 To RowsCount
results((ii - 1) * RowsCount + j, 1) = vals(i, 1)
Next j
End If
Next i
'write data block to fixed target starting with A392
.Range("A392").Resize(UBound(results), 1) = results
End With
End Sub
I'm trying to populate a listbox in excel with information that is a "matrix"(basically I have some data in the rows and some in the columns. I'm using the code below but I have 2 problems.
Dim Rows As Integer
Dim Kolumns As Integer
Dim Start As Range
Set Start = Sheets("sheet1").Range("B2")
Start.Select
Rows = 10
Kolumns = 5
For i = 1 To Rows
For j = 1 To Kolumns
ListBox1.AddItem
ListBox1.List(i - 1, j - 1) = ActiveCell.Offset(i - 1, j - 1).Value
Next j
Next i
The first problem is that the rows is being doubled, if I write "rows = 10" I then get 20 rows. (The columns work fine).
The second problem is my "select". I know that it's not the best option to use but I don't know how to avoid it?
As already written in the comment, you can use the range variable (in your case Start) directly to access the content of the cells.
The reason that you get 20 instead of 10 entries in the listbox is that you have the AddItem within the inner loop, and that is executed 10*2 = 20 times. You need to move it into the outer loop so that only one item per row is created:
Const rowCount = 10
Const colCount = 2
Dim Start As Range
Set Start = ThisWorkbook.Sheets("sheet1").Range("B2")
Dim i As Long, j As Long
For i = 1 To rowCount
ListBox1.AddItem
For j = 1 To colCount
ListBox1.List(i - 1, j - 1) = Start.Offset(i - 1, j - 1).Value
Next j
Next i
Try the next way, please. No need of any iteration. A ListBox has a List property which accept an array:
Sub loadListBox()
Dim sh As Worksheet, iRows As Long, Kolumns As Long, Start As Range, arr
Set sh = Sheets("Sheet1")
Set Start = sh.Range("B2")
iRows = 10: Kolumns = 5
arr = sh.Range(Start, Start.Offset(iRows, Kolumns)).Value
With ListBox1
.Clear
.ColumnCount = Kolumns + 1
.list = arr
End With
End Sub
Populate List Box
More efficient is not using a loop at all.
Note the use of the ColumnCount property which is used to ensure the right number of columns.
The Code
Option Explicit
Sub populateListBox()
Const rCount As Long = 10
Const cCount As Long = 5
Dim cel As Range: Set cel = Sheet1.Range("B2")
With Sheet1.ListBox1
.ColumnCount = cCount
.List = cel.Resize(rCount, cCount).Value
End With
End Sub
I'm using a for loop but I'm open suggestions if there's a better way to separate the data!
I want to insert two new rows whenever the integer in Column 11 or "K" changes. Column K represents groups of data and each is named with integers between 1 and 10 (inclusive). Each group varies in size, hence why I wanted a for loop to check each time the group increments to trigger the insertion of the rows.
For example:
From the data below two blank rows should be inserted below K11 and below K18. This will result in the data being separated by two blank rows whenever two groups were 'touching' each other.
K2 = 1, K3 = 1, K4 = 1 ... K11 = 1
K12 = 2, K13 = 2, K14 = 2... K18 = 2
K19 = 3, K20 = 3 ...
I've put together the following for loop but it inserts 500 (the counter limit) rows after the first group and no row inserts for the remaining groups. Can you explain why this happens and how I can work around this?
Dim LCounter As Integer
For LCounter = 2 To 500
If Cells(LCounter + 1, 11).Value <> Cells(LCounter, 11) Then
Rows(LCounter + 1).Insert shift:=xlShiftDown
End If
Next LCounter
Try this way, please. It should be very fast even for big ranges:
Sub SeparateGroupsByEmptyRows()
Dim LCounter As Long, col As Long, rng As Range
col = 11
For LCounter = 2 To 500
If cells(LCounter + 1, col).Value <> cells(LCounter, col).Value Then
If rng Is Nothing Then
Set rng = cells(LCounter + 1, col)
Else
Set rng = Union(rng, cells(LCounter + 1, col))
End If
End If
Next LCounter
'For the case of two or more consecutive groups of only one row each:
If InStr(rng.Address(0, 0), ":") > 0 Then Set rng = makeDiscontinuu(rng)
rng.EntireRow.Insert Shift:=xlDown
End Sub
Function makeDiscontinuu(rng As Range) As Range
Dim A As Range, c As Range, strAddress As String
For Each A In rng.Areas
If A.cells.count = 1 Then
strAddress = strAddress & A.Address(0, 0) & ","
Else
For Each c In A.cells
strAddress = strAddress & c.Address(0, 0) & ","
Next c
End If
Next A
Set makeDiscontinuu = Range(left(strAddress, Len(strAddress) - 1))
End Function
try this, should be one empty row separation (not tested)
Dim LCounter As Integer, lcEnd as integer: lcEnd =500
For LCounter = 2 To lcEnd
If Cells(LCounter + 1, 11).Value <> Cells(LCounter, 11) and Cells(LCounter + 1, 11)<> "" Then
Rows(LCounter + 1).Insert shift:=xlShiftDown
lcEnd =lcEnd +1
End If
Next LCounter
Insert Rows Before Change of Cell Value
The first procedure uses For...Next to solve the problem by looping backwards.
The second procedure uses Do...Loop illustrating the complications when looping forwards.
The Code
Option Explicit
Sub insertBeforeChangeForNext()
Const iRows As Long = 2 ' Number of Rows to Insert
Const cCol As Long = 11 ' Criteria Column
Const fRow As Long = 2 ' First Row
' Either...
Const lRow As Long = 500 ' Last Row
' ...or rather determine the last non-empty row:
'Dim lRow As Long: lRow = Cells(Rows.Count, cCol).End(xlUp).Row ' LR
If lRow <= fRow Then
Exit Sub
End If
Application.ScreenUpdating = False
Dim LCounter As Long ' Rows Counter
For LCounter = lRow - 1 To fRow Step -1
If Cells(LCounter + 1, cCol).Value <> Cells(LCounter, cCol).Value Then
Rows(LCounter + 1).Resize(iRows).Insert
End If
Next LCounter
Application.ScreenUpdating = True
End Sub
Sub insertBeforeChangeDoLoop()
Const iRows As Long = 2 ' Number of Rows to Insert
Const cCol As Long = 11 ' Criteria Column
Const fRow As Long = 2 ' First Row
' Either...
Const lRow As Long = 500 ' Initial Last Row
' ...or rather determine the last non-empty row:
'Dim lRow As Long: lRow = Cells(Rows.Count, cCol).End(xlUp).Row ' ILR
Dim Current As Long: Current = fRow ' Current Row
Dim Last As Long: Last = lRow ' Current Last Row
Application.ScreenUpdating = False
Do While Current < Last
If Cells(Current + 1, cCol).Value <> Cells(Current, cCol).Value Then
Rows(Current + 1).Resize(iRows).Insert
Last = Last + iRows
Current = Current + iRows
End If
Current = Current + 1
Loop
Application.ScreenUpdating = True
End Sub
I use the code hereunder to calculate max values as described in this post (vba max value of group of values). The code works great but once I have more than 65k lines I get a data type mismatch when trying to pase the array:
sht.Range(Cells(1, lColumn), Cells(last.Row, lColumn)).Value = Application.Index(groupsArray, , lColumn)
Could somebody help me to slice the array in chunks. I have tried to get it working myself but without any luck.
Sub FillGroupsMax()
Dim lColumn As Long
Dim sht As Worksheet
Dim groupsArray As Variant 'array with all group infomation
Dim groupsSeen As Variant 'array with group infomation already seen
Application.ScreenUpdating = False 'stop screen updating makes vba perform better
Set sht = ThisWorkbook.Worksheets("import")
Set last = sht.Range("A:A").Find("*", Cells(1, 1), searchdirection:=xlPrevious) 'last cell with value in column A
lColumn = sht.Cells(1, Columns.Count).End(xlToLeft).Column
groupsArray = sht.Range(Cells(1, 1), Cells(last.Row, lColumn))
'collect all the information on the Sheet into an array
'Improves performance by not visiting the sheet
For dRow = 2 To last.Row 'for each of the rows skipping header
'check if group as already been seen
If inArrayValue(Cells(dRow, 1).Value, groupsSeen) > 0 Then
'if it has been seen/calculated attribute value
'Cells(dRow, 4).Value = inArrayValue(Cells(dRow, 1).Value, groupsSeen)
groupsArray(dRow, lColumn) = inArrayValue(Cells(dRow, 1).Value, groupsSeen)
Else
'if it hasn't been seen then find max
'Cells(dRow, 4).Value = getMax(Cells(dRow, 1).Value, groupsArray)
groupsArray(dRow, lColumn) = getMax(Cells(dRow, 1).Value, groupsArray, lColumn)
'array construction from empty
If IsEmpty(groupsSeen) Then
ReDim groupsSeen(0)
'groupsSeen(0) = Array(Cells(dRow, 1).Value, Cells(dRow, 4).Value)
groupsSeen(0) = Array(groupsArray(dRow, 1), groupsArray(dRow, lColumn))
'attribute value to array
Else
ReDim Preserve groupsSeen(0 To UBound(groupsSeen) + 1)
groupsSeen(UBound(groupsSeen)) = Array(groupsArray(dRow, 1), groupsArray(dRow, lColumn))
End If
End If
Next
sht.Range(Cells(1, lColumn), Cells(last.Row, lColumn)).Value = Application.Index(groupsArray, , lColumn)
'reactivate Screen updating
Application.ScreenUpdating = True
End Sub
Function getMax(group As String, groupsArray As Variant, lColumn As Long) As Double
'for each in array
For n = 1 To UBound(groupsArray)
'if its the same group the Max we seen so far the record
If groupsArray(n, 1) = group And groupsArray(n, lColumn - 1) > maxSoFar Then
maxSoFar = groupsArray(n, lColumn - 1)
End If
Next
'set function value
getMax = maxSoFar
End Function
Function inArrayValue(group As String, groupsSeen As Variant) As Double
'set function value
inArrayValue = 0
'if array is empty then exit
If IsEmpty(groupsSeen) Then Exit Function
'for each in array
For n = 0 To UBound(groupsSeen)
'if we find the group
If groupsSeen(n)(0) = group Then
'set function value to the Max value already seen
inArrayValue = groupsSeen(n)(1)
'exit function earlier
Exit Function
End If
Next
End Function
You can write a helper function to use instead of Application.Index
Bonus - it will be much faster than using Index (>5x)
Sub Tester()
Dim arr, arrCol
arr = Range("A2:J80000").Value
arrCol = GetColumn(arr, 5) '<< get the fifth column
Range("L2").Resize(UBound(arrCol, 1), 1).Value = arrCol
End Sub
'extract a single column from a 1-based 2-D array
Function GetColumn(arr, colNumber)
Dim arrRet, i As Long
ReDim arrRet(1 To UBound(arr, 1), 1 To 1)
For i = 1 To UBound(arr, 1)
arrRet(i, 1) = arr(i, colNumber)
Next i
GetColumn = arrRet
End Function
EDIT - since QHarr asked about timing here's a basic example
Sub Tester()
Dim arr, arrCol, t, i as long
arr = Range("A2:J80000").Value
t = Timer
For i = 1 to 100
arrCol = GetColumn(arr, 5) '<< get the fifth column
Next i
Debug.print Timer - t '<<# of seconds for execution
End Sub
Below, whilst not as tidy as could be, is a way to process an array in chunks and Index to access a column and write out to the sheet.
I populated two columns (A:B) with data. Both had 132,000 rows, populated incrementally, with values from 1 to 132,000 in each column for my test run.
You can fiddle with cutOff to get the chunk size just below the point where the fail happens.
The code below is simply to demonstrate the principle of looping in batches, upto the set cutoff in each batch, until all rows have been processed.
Option Explicit
Public Sub WriteArrayToSheet()
Dim wb As Workbook
Dim ws As Worksheet
Set wb = ThisWorkbook
Set sht = wb.Worksheets("Sheet1") 'change as appropriate
Dim myArr() 'dynamic array
myArr = sht.Range("A1").CurrentRegion.Value 'you may want a more robust method
Dim cutOff As Long 'the max value - what ever it is before error occurs
cutOff = 1000
Dim totalRows As Long 'total rows in array read in from sheet
totalRows = UBound(myArr, 1)
Dim totalArraysNeeded As Long
'Determine how many lots of cutOff chunks there are in the total number of array rows
totalArraysNeeded = Application.WorksheetFunction.Ceiling(totalRows / cutOff, 1)
Dim rotations As Long 'number of times to loop original array to handle all rows
Dim rowCountTotal As Long
Dim rowCount As Long
Dim tempArr() 'this will hold the chunk of the original array
Dim rowCounter As Long
Dim lastRow As Long
Dim nextRow As Long
Dim i As Long
Dim j As Long
Dim numRows As Long
rotations = 1
Do While rotations < totalArraysNeeded
If rotations < totalArraysNeeded - 1 Then
ReDim tempArr(1 To cutOff, 1 To UBound(myArr, 2)) 'size chunk array
numRows = cutOff
Else
numRows = totalRows - rowCountTotal
ReDim tempArr(1 To numRows, 1 To UBound(myArr, 2)) 'size chunk array
End If
For i = 1 To numRows
rowCount = 1 'rows in this chunk looped
rowCountTotal = rowCountTotal + 1 'rows in original array looped
For j = LBound(myArr, 2) To UBound(myArr, 2)
tempArr(i, j) = myArr(rowCountTotal, j)
Next j
rowCount = rowCount + 1
Next i
With sht
lastRow = .Cells(.Rows.Count, "E").End(xlUp).Row 'Column where I am writing the sliced column out to
End With
If lastRow = 1 Then
nextRow = 1
Else
nextRow = lastRow + 1
End If
sht.Range("E" & nextRow).Resize(UBound(tempArr, 1), 1) = Application.Index(tempArr, , 1) 'write out to sheet
rotations = rotations + 1
Loop
End Sub
As #Tim suggested, the best way to slice a large array is use a loop to copy the column.
Though in your case, most of the processing time is spent on computing the maximum since your code is using a nested loop.
If you want to reduce significantly the processing time, then use a dictionary:
Sub Usage
GetMaxByGroupTo _
sourceGroups := ThisWorkbook.Range("Sheet1!A2:A100"), _
sourceValues := ThisWorkbook.Range("Sheet1!B2:B100"), _
target := ThisWorkbook.Range("Sheet1!C2")
End Sub
Sub GetMaxByGroupTo(sourceGroups As Range, sourceValues As Range, target As Range)
Dim dict As Object, groups(), values(), r As Long, max
Set dict = CreateObject("Scripting.Dictionary")
groups = sourceGroups.Value2
values = sourceValues.Value2
' store the maximum value of each group in a dictionary for an efficient lookup '
For r = Lbound(groups) to Ubound(groups)
max = dict(groups(r, 1))
If VarType(max) And values(r, 1) <= max Then Else dict(groups(r, 1)) = values(r, 1)
Next
' build and copy the result array to the sheet '
For r = Lbound(groups) to Ubound(groups)
values(r, 1) = dict(groups(r, 1))
Next
target.Resize(Ubound(groups), 1).Value2 = values
End Sub
I have a large table of lab measurement logs, which I work with using arrays.
(Im a chemist, a lab technician and Ive started to learn VBA only last week, please bear with me.)
Im trying to figure out, how to load the table into an array and then remove rows with an empty value in the 5th column so that I can "export" the table without blanks in the 5th column via an array into a different sheet.
I first tested this with some code I found for a 1D array, where I would make 2 arrays, one placeholder array which Id loop through adding only non-blanks to a second array.
For Counter = LBound(TestArr) To UBound(TestArr)
If TestArr(Counter, 1) <> "" Then
NoBlankSize = NoBlankSize + 1
NoBlanksArr(UBound(NoBlanksArr)) = TestArr(Counter, 1)
ReDim Preserve NoBlanksArr(0 To UBound(NoBlanksArr) + 1)
End If
Next Counter
It works in 1D, but I cant seem to get it two work with 2 dimensions.
Heres the array Im using for reading and outputting the data
Sub ArrayTest()
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Dim TestArray() As Variant
Dim Dimension1 As Long, Dimension2 As Long
Sheets("Tracker").Activate
Dimension1 = Range("A3", Range("A2").End(xlDown)).Cells.Count - 1
Dimension2 = Range("A2", Range("A2").End(xlToRight)).Cells.Count - 1
ReDim TestArray(0 To Dimension1, 0 To Dimension2)
'load into array
For Dimension1 = LBound(TestArray, 1) To UBound(TestArray, 1)
For Dimension2 = LBound(TestArray, 2) To UBound(TestArray, 2)
TestArray(Dimension1, Dimension2) = Range("A4").Offset(Dimension1, Dimension2).Value
Next Dimension2
Next Dimension1
Sheets("Output").Activate
ActiveSheet.Range("A2").Select
'read from array
For Dimension1 = LBound(TestArray, 1) To UBound(TestArray, 1)
For Dimension2 = LBound(TestArray, 2) To UBound(TestArray, 2)
ActiveCell.Offset(Dimension1, Dimension2).Value = TestArray(Dimension1, Dimension2)
Next Dimension2
Next Dimension1
Erase TestArray
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
End Sub
Thank you for any help in advance.
The Redim Preserve statement does not work for two-dimensional arrays if you want to change the number of records (rows).
You could load the range into an array, and then when you want to export the array to another range, loop through that array while skipping blank records.
An example:
Option Explicit
Sub ArrayTest()
Dim wb As Workbook, wsInput As Worksheet, wsOutput As Worksheet
Dim myArr As Variant
Dim i As Long, k As Long, LRow As Long
Set wb = ThisWorkbook
Set wsInput = wb.Sheets("Tracker")
Set wsOutput = wb.Sheets("Output")
LRow = wsOutput.Cells(wsOutput.Rows.Count, "A").End(xlUp).Row + 1
'Load a range into the array (example range)
myArr = wsInput.Range("A1:Z100")
'Fill another range with the array
For i = LBound(myArr) To UBound(myArr)
'Check if the first field of the current record is empty
If Not Len(myArr(i, 1)) = 0 Then
'Loop through the record and fill the row
For k = LBound(myArr, 2) To UBound(myArr, 2)
wsOutput.Cells(LRow, k) = myArr(i, k)
Next k
LRow = LRow + 1
End If
Next i
End Sub
From your code, it appears you want to
test a column of data on a worksheet to see if there are blanks.
if there are blanks in the particular column, exclude that row
copy the data with the excluded rows to a new area
You can probably do that easier (and quicker) with a filter: code below checking for blanks in column2
Option Explicit
Sub removeCol2BlankRows()
Dim wsSrc As Worksheet, wsRes As Worksheet
Dim rSrc As Range, rRes As Range
Set wsSrc = ThisWorkbook.Worksheets("sheet1")
Set rSrc = wsSrc.Cells(1, 1).CurrentRegion 'many ways to do this
Set wsRes = ThisWorkbook.Worksheets("sheet1")
Set rRes = wsRes.Cells(1, 10)
If wsSrc.AutoFilterMode = True Then wsSrc.AutoFilterMode = False
rSrc.AutoFilter field:=2, Criteria1:="<>"
rSrc.SpecialCells(xlCellTypeVisible).Copy rRes
wsRes.AutoFilterMode = False
End Sub
If you really just want to filter the VBA arrays in code, I'd store the non-blank rows in a dictionary, and then write it back to the new array:
Option Explicit
Sub removeCol2BlankRows()
Dim testArr As Variant
Dim noBlanksArr As Variant
Dim myDict As Object
Dim I As Long, J As Long, V
Dim rwData(1 To 4) As Variant
With ThisWorkbook.Worksheets("sheet1")
testArr = .Range(.Cells(1, 1), .Cells(.Rows.Count, 1).End(xlUp)).Resize(columnsize:=4)
End With
Set myDict = CreateObject("Scripting.Dictionary")
For I = 1 To UBound(testArr, 1)
If testArr(I, 2) <> "" Then
For J = 1 To UBound(testArr, 2)
rwData(J) = testArr(I, J)
Next J
myDict.Add Key:=I, Item:=rwData
End If
Next I
ReDim noBlanksArr(1 To myDict.Count, 1 To 4)
I = 0
For Each V In myDict.keys
I = I + 1
For J = 1 To 4
noBlanksArr(I, J) = myDict(V)(J)
Next J
Next V
End Sub