Trying to create a row range/list that stores all the row numbers with values in column A.
When I run the code I get the last VarRow() -> last row number instead of the entire range/list.
Many times, I could not run through VarRow(VarCount) = z + 1.
It stops at the row when the cell has the value so I cannot finish going to the next line of code (shows Subscript out of range).
Dim VarRow() As Double
VarCount = 0
VarCount2 = 0
For z = 1 To 350
If Range("A1").Offset(z, 0).Value <> 0 Then
VarCount = VarCount + 1
End If
Next z
ReDim Preserve VarRow(VaCount2)
For z = 1 To 350
If Range("A1").Offset(z, 0).Value <> 0 Then
VarCount2 = VarCount2 + 1
VarRow(VarCount) = z + 1
End If
Next z
Loop Through the Rows of a One-Column Range
Option Explicit
Sub RowNumbersToArray()
Const fRow As Long = 2
Const Col As String = "A"
Dim ws As Worksheet: Set ws = ActiveSheet ' improve!
Dim lRow As Long: lRow = ws.Cells(ws.Rows.Count, Col).End(xlUp).Row
Dim RowNumbers() As Long
Dim r As Long
Dim n As Long
For r = fRow To lRow
If ws.Cells(r, Col).Value <> 0 Then
ReDim Preserve RowNumbers(0 To n)
RowNumbers(n) = r
n = n + 1
End If
Next r
For n = 0 To n - 1
Debug.Print n, RowNumbers(n)
Next n
End Sub
Related
I have many tables that need data combined. I have combined some of the tables into a test table to test the code. I am sorting the unique values in column 'B' a-z before running my code. It is very slow with only ~3500 records. The actual total is over 100,000 records. I'm curious to see if I can load the whole table to an array and perform the same functions, but I'm not sure if it is possible.
My table structure is:
Unique ID
First
Last
Company
etc.
A1
John
A1
Doe
A1
company1
A2
Jay
Varnado
A3
Joe
Snuffy
A3
M.
company2
The desired outcome is:
Unique ID
First
Last
Company
etc.
A1
John
Doe
company1
A1
John
Doe
company1
A1
John
Doe
company1
A2
Jay
Varnado
A3
Joe M.
Snuffy
company2
A3
Joe M.
Snuffy
company2
Dim cel As Range, rng As Range, r As Range
Dim arr(14) As String, temp As String
Dim i As Long, b As Long, j As Long, lRow As Long, lRec As Long, c As Long
Dim ii As Integer, v As Integer, col As Integer
Dim dict As Scripting.Dictionary
Dim str() As String
Dim BenchMark As Double
BenchMark = Timer
lRow = Sheet3.Cells(Rows.Count, 1).End(xlUp).Row
For c = 3 To lRow
Debug.Print c
Set cel = Sheet3.Range("B" & c)
If Trim(cel.Offset(1, 0)) = Trim(cel.Value) Then
'Determine range of like keys
i = 1
Do Until cel.Offset(i, 0).Value <> cel.Value
i = i + 1
Loop
lRec = cel.Offset(i, 0).Row - 1
'Compare data
For i = 3 To 16
ii = i - 3
'Create rng and loop through each column
Set rng = Sheet3.Range(Sheet3.Cells(c, i), Sheet3.Cells(lRec, i))
Set dict = New Scripting.Dictionary 'CreateObject("Scripting.Dictionary")
For Each r In rng
If dict.Exists(r.Value) = False And Len(r.Value) > 0 Then
dict.Add r.Value, r.Value
End If
Next r
'Add to string array
'Debug.Print Split(Join(dict.Keys, "|"), "|")
str = Split(Join(dict.Keys, ","), ",")
arr(ii) = Join(str, ",")
Set dict = Nothing
Next i
'Set range equal to array
For j = cel.Row To lRec
v = 0
For col = 3 To 16
Sheet3.Cells(j, col) = arr(v)
Sheet3.Cells(j, col) = arr(v)
v = v + 1
Next col
Next j
'Go to last cell in range
c = lRec
Else: GoTo NextCel
End If
'Clear array
NextCel:
On Error Resume Next
'Debug.Print Join(arr, ",")
Erase arr
On Error GoTo 0
Next c
MsgBox ("Done in " & Timer - BenchMark)
End Sub
Assuming ID is in column B and output as single lines per ID to Sheet1 or with duplicates to Sheet2.
Option Explicit
Sub Process()
Dim dict As Object, key
Dim iLastRow As Long, n As Long, r As Long
Dim c As Integer, s As String
Dim arIn, arOut, t0 As Single: t0 = Timer
Set dict = CreateObject("Scripting.Dictionary")
iLastRow = Sheet3.Cells(Rows.Count, "B").End(xlUp).Row
arIn = Sheet3.Range("A1").Resize(iLastRow, 16).Value2
n = 0
' determine number of unique ids
For r = 3 To iLastRow
key = Trim(arIn(r, 2))
If Len(key) > 0 Then
If Not dict.exists(key) Then
n = n + 1
dict.Add key, n
End If
End If
Next
' dimension output array and fill
ReDim arOut(1 To n, 1 To 15)
For r = 3 To iLastRow
key = Trim(arIn(r, 2))
n = dict(key)
arOut(n, 1) = key
' concat columns
For c = 3 To 16
s = Trim(arIn(r, c))
If Len(s) > 0 Then
arOut(n, c - 1) = arOut(n, c - 1) & " " & s
End If
Next
Next
' output to sheet1
Sheet1.Range("A1").Resize(n, 15) = arOut
MsgBox "Done in " & Format(Timer - t0, "0.0 secs")
' or with duplicates to sheet2
For r = 3 To iLastRow
key = Trim(arIn(r, 2))
n = dict(key)
Sheet2.Cells(r, 2) = key
For c = 3 To 16
Sheet2.Cells(r, c) = arOut(n, c - 1)
Next
Next
End Sub
This assumes the data is on Sheet1 starting in A1.
Not sure how efficient it is.
Option Explicit
Sub Test()
Dim rngDst As Range
Dim dicIDs As Object
Dim dicData As Object
Dim arrData As Variant
Dim arrCols As Variant
Dim idxRow As Long
Dim idxCol As Long
Dim ky As Variant
Dim fld As Variant
Dim cnt As Long
With Sheets("Sheet1").Range("A1").CurrentRegion
arrCols = .Rows(1).Value
arrData = .Offset(1).Resize(.Rows.Count - 1).Value
End With
Set dicIDs = CreateObject("Scripting.Dictionary")
For idxRow = LBound(arrData, 1) To UBound(arrData, 1)
ky = arrData(idxRow, 1)
If dicIDs.exists(ky) Then
Set dicData = dicIDs(ky)
cnt = cnt + 1
Else
Set dicData = CreateBlankDic(arrCols)
End If
For idxCol = LBound(arrData, 2) To UBound(arrData, 2)
fld = arrCols(1, idxCol)
If arrData(idxRow, idxCol) <> "" Then
dicData(fld) = arrData(idxRow, idxCol)
End If
Next idxCol
Set dicIDs(ky) = dicData
Next idxRow
Set rngDst = Sheets("Sheet1").Range("A1").Offset(, UBound(arrCols, 2) + 2)
rngDst.Resize(1, UBound(arrCols, 2)).Value = arrCols
Set rngDst = rngDst.Offset(1).Resize(cnt, UBound(arrCols, 2))
ReDim arrData(1 To cnt, 1 To UBound(arrCols, 2))
cnt = 1
For Each ky In dicIDs.keys
Set dicData = dicIDs(ky)
idxCol = 1
For Each fld In dicData.keys
arrData(cnt, idxCol) = dicData(fld)
idxCol = idxCol + 1
Next fld
cnt = cnt + 1
Next ky
rngDst.Value = arrData
End Sub
Function CreateBlankDic(arrKeys, Optional BlankVal = "") As Object
Dim dic As Object
Dim idxCol As Long
Set dic = CreateObject("Scripting.Dictionary")
For idxCol = LBound(arrKeys, 2) To UBound(arrKeys, 2)
dic(arrKeys(1, idxCol)) = BlankVal
Next idxCol
Set CreateBlankDic = dic
End Function
I have Integer values in a 3x3 matrix in the range B2:D4.
I made a nested loop checking each cell until it found an empty one (stop condition for each line read).
I can read the values from each cell and store at the positions of the vector, but when I check the values contained in the vector, only the value of the last position of the vector is displayed.
I need to get all the values to a subroutine that will work with these small vectors.
Option Explicit
Option Base 1
Sub Main()
Dim vet(1 to 3) As Variant
Dim lin As Long
Dim col As Long
Dim i As Long
Sheets("Sheet1").Select
lin = 2
col = 2
i = 1
Cells(lin, col).Activate
Do Until Cells(lin, 1) = ""
col = 2
Do Until Cells(lin, col) = ""
Cells(lin, col).Select
vet(i) = Cells(lin, col).Value
col = col + 1
Loop
' At this point, when checking the vector, only contains the last value
Call showVet(vet())
lin = lin + 1
Loop
End Sub
Sub showVet(ByRef v() As Variant)
Dim i As Long
For i = 1 To 3
Debug.Print (v(i))
Next i
' And at this point, only the last value that was passed ...
End Sub
Look at this:
Option Base 1
Sub Main()
Dim vet(1 To 3) As Variant
Dim lin As Long
Dim col As Long
Dim i As Long
With Sheets("Sheet1")
lin = 2
Do Until Cells(lin, 1) = ""
i = 1
col = 2
Do Until Cells(lin, col) = ""
.Cells(lin, col).Select
vet(i) = Cells(lin, col).Value
i = i + 1
col = col + 1
Loop
Call showVet(vet())
lin = lin + 1
Loop
End With
End Sub
Sub showVet(ByRef v() As Variant)
Dim i As Long
For i = 1 To 3
Debug.Print (v(i))
Next i
End Sub
I have a problem where I have created an Array with variables and I want to enter the values in my Array in a separate column which does not match the row index of my Array.
I want to loop through a column and I want to return a value from an Array which does not correspend with the row index of the column. That could for example be to return the first value of my Array on the sixth row.
I Think that my problem probably lies in that I don't know how to set up the nested loop.
Many thanks for any help
I have created my Array like this
Sub arraytest()
Dim MonthArray() As String
Dim Lastrow As Long
Dim StartRow As Byte
StartRow = 2
Dim r As Byte
Lastrow = Range("B" & StartRow).CurrentRegion.Rows.count
If Lastrow > 0 Then
ReDim MonthArray(StartRow To Lastrow)
For r = StartRow To Lastrow
MonthArray(r) = Range("C" & r).Value
Next r
End If
End Sub
So if I have the values in my Array
MonthArray()
Month 1
Month 2
Month 3
Month 4
Month 5
Month 6
Then a simple loop without taking into account row index would be
For i = StartRow To Lastrow
If (Cells(i, "A").Value = "USA:" or Cells(i, "A").Value = "EU:") Then _
Cells(i, "B").Value = " " Else Cells(i, "B").Value = MonthArray(i) <<<
Next i
This would return a table in this order
1 USA:
2 Data MonthArray(2)
3 Data MonthArray(3)
4 EU:
5 Data MonthArray(5)
6 Data MonthArray(6)
But I need the array to be returned like this:
1 USA:
2 Data MonthArray(1)
3 Data MonthArray(2)
4 EU:
5 Data MonthArray(3)
6 Data MonthArray(4)
So, in this case, I want to add the value from my Array if the value in the A column is not USA or EU
What I have tried is this
r = 1
For i = StartRow To Lastrow
If (Cells(i, "A").Value = "USA" or Cells(i, "A").Value = "EU") Then _
Cells (i, "B").Value = " " Next i Else Cells(i, "B").Value = MonthArray (r) <<<
r = r + 1
Next i
However, I want
r = r + 1
To occur only if (Cells(i, "A").Value = "USA" or Cells(i, "A").Value = "EU")
Any help is highly appreciated
If you have a contiguous range for your MonthArray, don't worry about looping and just use:
Dim MonthArray() As Variant, StartRow as Long, LastRow as Long
StartRow = 2
Lastrow = Cells(StartRow, "B").CurrentRegion.Rows.count
MonthArray = Range(Cells(StartRow, "C"), Cells(LastRow, "C")).Value
Then we move into using the array, like your code indicates:
Dim r as Long, i as Long
r = 1
For i = StartRow To Lastrow
If UCase(Cells(i, "A").Value) = "USA" or UCase(Cells(i, "A").Value) = "EU" Then
Cells(i, "B").Value = " "
Else
Cells(i, "B").Value = MonthArray(r,1)
r = r + 1
End If
Next i
Need your r = r+1 in the loop as you move down.
Edit1:
Make sure to add in Sheet references. Assumption made from my testing, where I don' want to be overwriting my cells in B if I determine LastRow based on col B, e.g.:
With Sheets("MonthSource")
Dim MonthArray() As Variant, StartRow as Long, LastRow as Long
StartRow = 2
Lastrow = .Cells(StartRow, "B").CurrentRegion.Rows.count
MonthArray = .Range(.Cells(StartRow, "C"), .Cells(LastRow, "C")).Value
End With
With Sheets("Destination")
Dim r as Long, i as Long
r = 1
For i = StartRow To Lastrow
If UCase(.Cells(i, "A").Value) = "USA" or UCase(.Cells(i, "A").Value) = "EU" Then
.Cells(i, "B").Value = " "
Else
.Cells(i, "B").Value = MonthArray(r,1)
r = r + 1
End If
Next i
End With
Something like this should work for you:
Sub tgr()
Dim ws As Worksheet
Dim MonthArray() As Variant
Dim StartRow As Long
Dim LastRow As Long
Dim i As Long, r As Long
'Always fully qualify workbook and worksheet you're working with, change this as necessary
Set ws = ActiveWorkbook.ActiveSheet
StartRow = 2
LastRow = ws.Cells(StartRow, "B").CurrentRegion.Rows.Count
'Load the values of column C into an array directly, no loop required
With ws.Range(ws.Cells(StartRow, "C"), ws.Cells(LastRow, "C"))
If .Row < StartRow Then Exit Sub 'No data
If .Cells.Count = 1 Then
'Only a single value found in column C, force array type by manually redimming and adding the value
ReDim MonthArray(1 To 1, 1 To 1)
MonthArray(1, 1) = .Value
Else
'Multiple values found in column C, can insert values into array directly
MonthArray = .Value
End If
End With
'Initialize your array index counter variable at 0 to start
r = 0
'Begin loop of rows
For i = StartRow To LastRow
'Check contents of column A
Select Case UCase(Trim(ws.Cells(i, "A").Value))
Case "USA:", "EU:"
'do nothing
Case Else
'increase array index counter variable
r = r + 1
'Output the appropriate array value to column B
ws.Cells(i, "B").Value = MonthArray(r, 1)
End Select
Next i 'advance row counter
End Sub
if i have data filled in worksheet like shown in image, i want to create a 2D array and fill it with data in such way of the selected cells in the image, i.e to take the 1st value and skip the next two values and so on till the end of the array and by same way in columns
i made a solution which delete the intermediate rows and columns but for large array (example of 1000*1000),it takes a lot of time that is why i thought in another way to create array with the above criteria.
this is the code i used for deleting the intermediate rows and columns:
Sub Sorting()
Dim LastRow As Long
LastRow = sh.Range("A1", sh.Range("A1").End(xlDown)).rows.count
For cntr = 1 To LastRow / 3
rows(cntr + 1 & ":" & cntr + 2).EntireRow.Delete
Next
Dim LastColumn As Long
LastColumn = sh.Range("A1").CurrentRegion.Columns.count
K = LastColumn
For cntr = 1 To K / 3
Columns(cntr + 1).EntireColumn.Delete
Columns(cntr + 1).EntireColumn.Delete
Next
End Sub enter code here
Something like this should work for you:
Sub tgr()
Dim ws As Worksheet
Dim aData As Variant
Dim aResults() As Variant
Dim lRow As Long, lCol As Long
Dim i As Long, j As Long
Dim lRowInterval As Long
Dim lColInterval As Long
Set ws = ActiveWorkbook.ActiveSheet
lRowInterval = 3
lColInterval = 3
aData = ws.Range("A1").CurrentRegion
ReDim aResults(1 To Int(UBound(aData, 1) / lRowInterval), 1 To Int(UBound(aData, 2) / lColInterval))
i = 0
For lRow = 1 To UBound(aData, 1) Step lRowInterval
i = i + 1
j = 0
For lCol = 1 To UBound(aData, 2) Step lColInterval
j = j + 1
aResults(i, j) = aData(lRow, lCol)
Next lCol
Next lRow
'Do what you want with the array aResults here
End Sub
I am trying to go through an array to find duplicate entries in a single column of that array and delete the entire row.
I am getting figuring out rangeStart, rangeEnd, and lastrow above this and that part is working fine.
data = Range(rangeStart, rangeEnd)
For i = lastrow - 1 To 2 Step -1
If data(i - 1, x) = data(i, x) Then
'Delete data(i)
End If
Next
Any help with this would be awesome!
Sub RemoveDups()
Const COMPARE_COL as Long = 1
Dim a, aNew(), nr As Long, nc As Long
Dim r As Long, c As Long, rNew As Long
Dim v As String, tmp
a = Selection.Value
nr = UBound(a, 1)
nc = UBound(a, 2)
ReDim aNew(1 To nr, 1 To nc)
rNew = 0
v = Chr(0)
For r = 1 To nr
tmp = a(r, COMPARE_COL)
If tmp <> v Then
rNew = rNew + 1
For c = 1 To nc
aNew(rNew, c) = a(r, c)
Next c
v = tmp
End If
Next r
Selection.Value = aNew
End Sub
Does this help?:
If data(i - 1, x) = data(i, x) Then
data(i,x).EntireRow.Delete
End If
Why not use Excel's inbuilt Unique options (Data ... Remove Duplicates)?
Another efficient VBA method is to use a Dictionary.
Sub A_Unique_B()
Dim X
Dim objDict As Object
Dim lngRow As Long
Set objDict = CreateObject("Scripting.Dictionary")
X = Application.Transpose(Range([a1], Cells(Rows.Count, "A").End(xlUp)))
For lngRow = 1 To UBound(X, 1)
objDict(X(lngRow)) = 1
Next
Range("B1:B" & objDict.Count) = Application.Transpose(objDict.Keys)
End Sub