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
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
Is there a way to have this script form the entire array based off the rows I want it to extract based on the IF Statement?
I know this finds a name on the Mgrs worksheet, and finds those rows in the Data worksheet, but then it directly prints it after forming the array. Can I have this code store all of the data, and then wait to print the data on a template that I format myself?
Option Explicit
Sub CIB_Cuts()
Dim j As Long, k As Long, x As Long
Dim varArray() As Variant
Dim varArray2() As Variant
ReDim varArray(1 To 19, 1 To 1)
Dim strManager As String, strEC As String, strLogin As String
Dim BASEPATH As String, strNewPath As String, strFileName As String
Dim Wb As Workbook
Dim mgrRow As Long
Dim colManager As Long
colManager = 3
Dim colLogin As Long
colLogin = 4
Dim colEC As Long
colEC = 5
BASEPATH = "M:\Final Files\"
Call speedupcode(True)
For mgrRow = 2 To ThisWorkbook.Worksheets("Mgrs").UsedRange.Rows.Count
If ThisWorkbook.Worksheets("Mgrs").Cells(mgrRow, 3) <> "" Then
strManager = ThisWorkbook.Worksheets("Mgrs").Cells(mgrRow, 3)
With ThisWorkbook.Worksheets("Data")
ReDim varArray(1 To UBound(varArray, 1), 1 To 1)
x = 1
For k = 1 To UBound(varArray, 1)
varArray(k, x) = .Cells(1, k)
Next
For j = 2 To .UsedRange.Rows.Count + 1
If strManager = .Cells(j, colManager) Then
x = x + 1
ReDim Preserve varArray(1 To UBound(varArray, 1), 1 To x)
For k = 1 To UBound(varArray, 1)
If k = 1 Then
varArray(1, x) = CStr(Format(.Cells(j, k), "000000000"))
Else
varArray(k, x) = .Cells(j, k)
End If
strEC = .Cells(j, colEC)
strManager = .Cells(j, colManager)
strLogin = .Cells(j, colLogin)
Next
End If
Next
End With
strFileName = strLogin & " - " & strManager & " - " & "Shift Differential Validation" & ".xlsx"
ReDim varArray2(1 To UBound(varArray, 2), 1 To UBound(varArray, 1))
Set Wb = Workbooks.Add(XlWBATemplate.xlWBATWorksheet)
With Wb
With .Worksheets("Sheet1")
.Columns(1).NumberFormat = "#"
.Columns(15).NumberFormat = "0%"
For j = 1 To UBound(varArray, 2)
For k = 1 To UBound(varArray, 1)
varArray2(j, k) = varArray(k, j)
Next
Next
.Range(.Cells(1, 1), .Cells(UBound(varArray, 2), UBound(varArray, 1))) = varArray2
Call DataValidation
Call Header
.Range("C2").Select
ActiveWindow.FreezePanes = True
.Cells.EntireColumn.AutoFit
.Rows("1:1").Font.Bold = True
Call protect
End With
.SaveAs strNewPath & strFileName, Password:="password", FileFormat:=51
.Saved = True
.Close
End With
Set Wb = Nothing
End If
Next
Call speedupcode(False)
End Sub
You could store the array each time in an overarching array or a collection and loop that at the end...
Public Sub test()
Dim varArray2() As Variant, results As Collection
'other code..
Set results = New Collection
results.Add varArray2
End Sub
You could also use Select Case , or something distinctive during the loop, to determine a key and populate a dictionary with the arrays as values which might make retrieval of specific items easier.
data series
I want to find the average for each segment of ten values down a column. (See data series picture)
Continuously all the way to the bottom of the data set. The data set can vary in length, and the code has to be "generic" of sorts.
Based on other code segments I have tried to do this:
Sub tenthavg()
Dim currentIndex As Long
Dim myArray() As Variant
Dim rng As Range
ReDim myArray(1 To 10)
Range("b1", Range("b1").End(xlDown)).Select
Set myArray = Selection
currentIndex = 1
Do Until currentIndex + 1 > UBound(myArray)
ActiveSheet.Cells(currentIndex, "T") = AverageOfSubArray(myArray, currentIndex, 10)
currentIndex = currentIndex + 1
Loop
End Sub
'=================================================================
Function AverageOfSubArray(myArray As Variant, startIndex As Long, elementCount As Long) As Double
Dim runningTotal As Double
Dim i As Long
For i = startIndex To (startIndex + elementCount - 1)
runningTotal = runningTotal + val(myArray(i))
Next i
AverageOfSubArray = runningTotal / elementCount
End Function
Unfortunately I can't make it work. Am I approaching this the right way?
If so, what am I doing wrong?
IMHO it's not quite the successful approach ... instead of Selecting EndDown and other concepts borrowed from interactive working make use of VBA's own mechanisms.
A "generic" approch takes Range start address, batch size and offsets where to put the result as arguments ...
Sub AvgX(MyR As Range, S As Integer, ORow As Integer, OCol As Integer)
' MyR = start of range
' S = batch size
' OCol, ORow = Offsets to place result in relation to last batch value
Dim Idx As Integer, Jdx As Integer, RSum As Variant
Idx = 1
RSum = 0
Do
For Jdx = 1 To S
RSum = RSum + MyR(Idx, 1)
Idx = Idx + 1
If MyR(Idx, 1) = "" Then Exit Do
Next Jdx
MyR(Idx - 1, 1).Offset(ORow, OCol) = RSum / (Jdx - 1)
RSum = 0
Loop
End Sub
and is called by
Sub Test()
AvgX [C4], 10, 0, 1
End Sub
to give you this result ...
You can get your result in a simpler way:
Sub tenthavg()
Dim LastRow As Long
LastRow = ThisWorkbook.Sheets("Your Sheet Name").Columns(2).Find("*", SearchOrder:=xlByRows, LookIn:=xlValues, SearchDirection:=xlPrevious).Row
Dim myArray(1 To 10) As Double
If LastRow < 10 Then
MsgBox "There's not enough data!"
Else
On Error Resume Next
For x = 1 To LastRow - 9
For y = 1 To 10
myArray(y) = ThisWorkbook.Sheets("Your Sheet Name").Cells(y + x - 1, 2).Value
Next y
ThisWorkbook.Sheets("Your Sheet Name").Cells(x, 20).FormulaR1C1 = 0
ThisWorkbook.Sheets("Your Sheet Name").Cells(x, 20).FormulaR1C1 = Application.Average(myArray)
Next x
End If
End Sub
Please note: I'm assuming you're data starts at B1 and you want the output on column T.
first of all, i'd like to say, i've sarched thorugh the net, but i haven't run into such a thing. i've seen collection of collections, or array of arrays, but not a collection of array.
what i want to do is, to collect ID's in collections for each District. Finally, i will join the values in the collections with Join function and ";" as delimiter, and then print them in a range of 4 column as a lookup list, for each class. For example;
Class2(0) will include 54020 and 30734, class2(1) will include 58618, class1(4) will include none, class3(7) will include 35516,34781 and 56874, and so on.
i want to loop through column C and put a select case statment to check the class and then assign the values to collections
Sub dict_coll()
Dim class1() As New Collection
Dim class2() As New Collection
Dim class3() As New Collection
Dim class4() As New Collection
Dim dict As New Scripting.Dictionary
Set dRange = range(range("a2"), range("a2").End(xlDown))
i = 0
For Each d In dRange
If Not dict.Exists(d.Value) Then
dict.Add key:=d.Value, item:=i
i = i + 1
End If
Next d
Set cRange = range(range("c2"), range("c2").End(xlDown))
For Each c In cRange
Select Case c.Value
Case "class1"
class1(dict(c.offset(0,-2).value)).Add c.Offset(0, 1).Value 'fails here
Case "class2"
class2(dict(c.offset(0,-2).value)).Add c.Offset(0, 1).Value 'fails here
Case "class3"
class3(dict(c.offset(0,-2).value)).Add c.Offset(0, 1).Value 'fails here
Case Else
class4(dict(c.offset(0,-2).value)).Add c.Offset(0, 1).Value 'fails here
End Select
Next c
End Sub
and what i want to see is as foloowing:
is there any easier and proper way of what i wanna do? any help wil be appreciated.
thanks
I didnt see that sb variable defined in your code.
Anyway, for me I see a case of straightforward arrays: There is fixed dimension of classes so it good enough for me. Furthermore, you can print back to worksheet so easily.
Public Sub test()
Const strPrefix = "class"
Dim districtRange As Range, outputRange As Range, r As Range
Dim arr() As String
Dim i As Long, j As Long, x As Long, y As Long
Dim district As String, str As String, idVal As String
Dim arr2 As Variant
Application.ScreenUpdating = False
ReDim arr(1 To 5, 1 To 1)
arr(1, 1) = "District"
arr(2, 1) = "Class 1"
arr(3, 1) = "Class 2"
arr(4, 1) = "Class 3"
arr(5, 1) = "Class 4"
Set districtRange = Range(Range("A2"), Range("C2").End(xlDown))
arr2 = districtRange.Value
For x = LBound(arr2, 1) To UBound(arr2, 1)
district = arr2(x, 1)
i = Val(Mid(arr2(x, 3), Len(strPrefix) + 1))
idVal = arr2(x, 2)
j = inArray(arr, district, 1) 'returns -1 if not found
If j >= 0 Then
arr(i + 1, j) = IIf(arr(i + 1, j) = "", idVal, arr(i + 1, j) & ";" & idVal)
Else
ReDim Preserve arr(1 To 5, 1 To UBound(arr, 2) + 1)
arr(1, UBound(arr, 2)) = district
arr(i + 1, UBound(arr, 2)) = idVal
End If
Next x
Set outputRange = Range("E1")
outputRange.Resize(UBound(arr, 2), UBound(arr, 1)).Value = Application.Transpose(arr)
outputRange.Sort Key1:=Range("E1"), Header:=xlYes, Order1:=xlAscending
Application.ScreenUpdating = True
End Sub
Public Function inArray(arr As Variant, k As String, Optional rowNum As Long, Optional colNum As Long) As Long
Dim i As Long, j As Long
inArray = -1
If rowNum Then
For i = LBound(arr, 2) To UBound(arr, 2)
If arr(rowNum, i) = k Then
inArray = i
Exit Function
End If
Next i
Else
For i = LBound(arr, 1) To UBound(arr, 1)
If arr(i, colNum) = k Then
inArray = i
Exit Function
End If
Next i
End If
End Function
by the way, i've found another solution, usinf both dictionary and 3-dimension array.
Sub test()
Dim Blg As New Scripting.Dictionary
Dim Sgm As New Scripting.Dictionary
Dim Siciller() As String
ReDim Siciller(0 To 23, 0 To 3, 0 To 5)
Set alanBolge = range(range("a2"), range("a2").End(xlDown))
Set alanSegment = range(range("c2"), range("c2").End(xlDown))
i = 0
For Each d In alanBolge
If Not Blg.Exists(d.Value) Then
Blg.Add Key:=d.Value, item:=i
i = i + 1
End If
Next d
k = 0
For Each d In alanSegment
If Not Sgm.Exists(d.Value) Then
Sgm.Add Key:=d.Value, item:=k
k = k + 1
End If
Next d
'data reading
For Each d In alanBolge
Siciller(Blg(d.Value), Sgm(d.Offset(0, 2).Value), dolusay(Siciller, Blg(d.Value), Sgm(d.Offset(0, 2).Value)) + 1) = d.Offset(0, 1).Value
Next d
'output
For x = 1 To 4
For y = 1 To 24
Set h = Cells(1 + y, 5 + x)
h.Select
h.Value = sonucgetir(Siciller, Blg(h.Offset(0, -x).Value), Sgm(h.Offset(-y, 0).Value))
Next y
Next x
End Sub
Public Function dolusay(ByVal data As Variant, ByVal i1 As Integer, ByVal i2 As Integer) As Integer
Dim count As Integer
count = 0
For j = 0 To UBound(data, 3) - 1
If Len(data(i1, i2, j)) > 0 Then
count = count + 1
End If
Next
dolusay = count
End Function
Public Function sonucgetir(ByVal data As Variant, ByVal i1 As Integer, ByVal i2 As Integer) As String
sonucgetir = ""
For i = 0 To UBound(data, 3)
If Len(data(i1, i2, i)) > 0 Then
x = data(i1, i2, i) & ";" & x
sonucgetir = Left(x, Len(x) - 1)
End If
Next i
End Function
I've a worksheet named "GetData". In this worksheet are more columns.
A(Names)|B... |C(Center)
++++++++|+++++++|+++++++++
Alpha | |100-Base
Beta | |110-2nd
Charly | |100-Base
Now I want sort them into another worksheet named "Overview" like this:
A(Grouped)
++++++++++
100-Base
Alpha
Charly
110-2nd
Beta
I think I need an array, but I don't know how to build this. I tried this for beginning:
Sub unique4()
Dim arr As New Collection, a
Dim aFirstArray() As Variant
Dim i As Long
Dim LastRow As Long
LastRow = Worksheets("GetData").Cells(Worksheets("GetData").Rows.Count, "C").End(xlUp).Row
aFirstArray() = Worksheets("GetData").Range("C2:C" & LastRow).Value
On Error Resume Next
For Each a In aFirstArray
arr.Add a, a
Next
For i = 1 To arr.Count
Cells(i, 1) = arr(i)
Next
End Sub
Here is one without arrays,
Sub unique4()
Dim i As Long
Dim lastrow As Long
Dim j As Long
Dim tws As Worksheet
Set tws = Sheets("Sheet2")'Change to desired sheet output name.
j = 1
With Sheets("GetData")
lastrow = .Cells(.Rows.Count, "C").End(xlUp).Row
For i = 1 To lastrow
If i <> 1 Then
If .Cells(i, 3) <> .Cells(i - 1, 3) Then
tws.Cells(j, 1) = .Cells(i, 3)
j = j + 1
tws.Cells(j, 1) = .Cells(i, 1)
j = j + 1
Else
tws.Cells(j, 1) = .Cells(i, 1)
j = j + 1
End If
Else
tws.Cells(j, 1) = .Cells(i, 3)
j = j + 1
tws.Cells(j, 1) = .Cells(i, 1)
j = j + 1
End If
Next
End With
End Sub
One Caveat, you will need to sort the data on column C to make work.
this should solve your issue with just an Excel formula. If you want a vba solution, that is of course possible too.
In your new sheet, in column A Setup it like:
Column A
1
1
2
2
3
3
You can get this format by entering the following in Cell A3 and pull it down as far as you need (set Cell A1, A2 with a value of 1).
=A1+1
In Column B you are going to enter an Indirect Formula. In cell B1, put this:
=INDIRECT("Sheet1!A"&A1)
In Cell B2, put this:
=INDIRECT("Sheet1!C"&A2)
Column A will keep track of which row to pull from, then the indirect formula will dynamically build the formula to get the value. Hope it helps!
Without sorting any data or something like that:
Sub test()
Dim LastRow As Long, i As Long, j As Long, k As Long, chkB As Boolean
Dim wsGet As Worksheet, wsPut As Worksheet
Set wsGet = ThisWorkbook.Worksheets(1)
Set wsPut = ThisWorkbook.Worksheets(2)
Const FirstRow As Long = 3
LastRow = wsGet.Range("C" & wsGet.Rows.Count).End(xlUp).Row
For i = FirstRow To LastRow
chkB = True
For j = FirstRow To i - 1
If wsGet.Cells(i, 3) = wsGet.Cells(j, 3) Then chkB = False: Exit For
Next
If chkB Then
k = k + 1
wsPut.Cells(k, 1) = wsGet.Cells(i, 3)
For j = i To LastRow
If wsGet.Cells(j, 3) = wsGet.Cells(i, 3) Then
k = k + 1
wsPut.Cells(k, 1) = wsGet.Cells(j, 1)
End If
Next
End If
Next
End Sub