Related
i tried using dictionary but it only counts the repetition but i want to know the exact frequency of all datas in a column
what ive used is
Sub countThings()
Dim ws As Worksheet
Dim lastrow As Long, x As Long
Dim items As Object
Application.ScreenUpdating = False
Set ws = ActiveSheet
lastrow = ws.Range("B" & Rows.count).End(xlUp).Row
Set items = CreateObject("Scripting.Dictionary")
For x = 2 To lastrow
If Not items.exists(ws.Range("B" & x).Value) Then
items.Add ws.Range("B" & x).Value, 1
ws.Range("C" & x).Value = items(ws.Range("B" & x).Value)
Else
items(ws.Range("B" & x).Value) = items(ws.Range("B" & x).Value) + 1
ws.Range("C" & x).Value = items(ws.Range("B" & x).Value)
End If
Next x
items.RemoveAll
End Sub
and this gives me
[1: https://i.stack.imgur.com/Mhp5g.png][1]
but what i need is
[4: https://i.stack.imgur.com/UYOFu.png][4]
I think this is what you were after. Please try it.
Sub CountThings()
Dim Ws As Worksheet
Dim Items As Object ' Scripting.Dictionary
Dim Arr As Variant ' values in column B
Dim R As Long ' loop couner: Rows
Dim Key As Variant ' loop counter: dictionary keys
Set Items = CreateObject("Scripting.Dictionary")
Set Ws = ActiveSheet ' better: define tab by name
With Ws
' reading from the sheet is slow
' therefore read all items at once
Arr = .Range(.Cells(2, "B"), .Cells(.Rows.Count, "B").End(xlUp)).Value
' this is a 1-based 2-D array, like Arr([Rows], [Column])
' where column is always 1 because there's only 1 column
End With
For R = 1 To UBound(Arr)
If Items.Exists(Trim(Arr(R, 1))) Then
Items(Trim(Arr(R, 1))) = Items(Trim(Arr(R, 1))) + 1
Else
Items.Add Trim(Arr(R, 1)), 1
End If
Next R
ReDim Arr(1 To Items.Count, 1 To 2)
R = 0
For Each Key In Items.keys
R = R + 1
Arr(R, 1) = Key
Arr(R, 2) = Items(Key)
Next Key
' specify the top left cell of the target range
Ws.Cells(2, "C").Resize(UBound(Arr, 1), UBound(Arr, 2)).Value = Arr
Set Items = Nothing
End Sub
You need not Trim the Keys if you are sure that there can't be any stray leading or trailing blanks.
Your second picture doesn't need VBA. It can be produce by this formula, entered in C2 and copied down.
=COUNTIF($B$2:$B$13,$B2)
In fact, you can even do the job of my above code without VBA. Enter this formula in G2 of your sheet as an array formula (confirmed with CTL + SHIFT + ENTER if you don't have Excel 365), and the other one in H. Then copy both formulas down.
[G2] =IFERROR(INDEX($B$2:$B$13, MATCH(0, COUNTIF($G$1:G1, $B$2:$B$13), 0)), "")
[H2] =IF($G2<>"",COUNTIF($B$2:$B$13,$G2),"")
You need to assign values to column C after you have finished counting and therefore, need another loop:
Sub countThings()
Dim ws As Worksheet
Dim lastrow As Long, x As Long
Dim items As Object
Application.ScreenUpdating = False
Set ws = ActiveSheet
lastrow = ws.Range("B" & Rows.Count).End(xlUp).Row
Set items = CreateObject("Scripting.Dictionary")
For x = 2 To lastrow
If Not items.exists(ws.Range("B" & x).Value) Then
items.Add ws.Range("B" & x).Value, 1
Else
items(ws.Range("B" & x).Value) = items(ws.Range("B" & x).Value) + 1
End If
Next x
For x = 2 To lastrow
ws.Range("C" & x).Value = items(ws.Range("B" & x).Value)
Next x
items.RemoveAll
Set items = Nothing
End Sub
A simpler way to achieve what you want is to let excel do the counting for you like this:
Sub countThings2()
Dim sDataAddress As String
With ActiveSheet
sDataAddress = "$B$2:$B$" & .Cells(Rows.Count, "B").End(xlUp).Row
With .Range(sDataAddress).Offset(0, 1)
.Formula2 = "=COUNTIF(" & sDataAddress & ",B2)"
.Value = .Value
End With
End With
End Sub
i use table and 2 functions. not simple way but works :)
Sub Fx()
Dim str_Tab() As String, str_Text As String, str_Result As String
Dim int_Counter As Integer, int_TabItemCounter As Integer, int_LastRow As Integer
Dim rng_WorkRange As Range
int_LastRow = ActiveSheet.Range("A" & Rows.Count).End(xlUp).Row
Set rng_WorkRange = ActiveSheet.Range("A1:A" & int_LastRow)
For i = 1 To int_LastRow
str_Text = ActiveSheet.Range("A" & i)
If i > 1 Then
str_Result = IsInArray(str_Text, str_Tab)
If str_Result = -1 Then
int_TabItemCounter = UBound(str_Tab) - LBound(str_Tab)
ReDim str_Tab(int_TabItemCounter)
str_Tab(int_TabItemCounter) = str_Text
ActiveSheet.Range("B" & i) = CountThisItem(rng_WorkRange, str_Text)
Else
ActiveSheet.Range("B" & i) = CountThisItem(rng_WorkRange, str_Text)
End If ' If str_Result = -1
Else ' If i > 1
ReDim str_Tab(i)
str_Tab(i) = str_Text
ActiveSheet.Range("B" & i) = CountThisItem(rng_WorkRange, str_Text)
End If ' If i > 1
Next i
End Sub
function to check is text in table
Function IsInArray(stringToBeFound As String, arr As Variant) As Long
Dim i As Long
' default return value if value not found in array
IsInArray = -1
For i = LBound(arr) To UBound(arr)
If StrComp(stringToBeFound, arr(i), vbTextCompare) = 0 Then
IsInArray = i
Exit For
End If
Next i
End Function
function to count item in range
Function CountThisItem(CountingRange As Range, a As String) As Integer
Dim rng_FindRange As Range
Dim LA As String
Set rng_FindRange = CountingRange.Find(a, lookat:=xlWhole)
If Not rng_FindRange Is Nothing Then
LA = rng_FindRange.Address
CountThisItem = 1
Do
Set rng_FindRange = CountingRange.Find(a, lookat:=xlWhole, after:=rng_FindRange)
If Not rng_FindRange Is Nothing And rng_FindRange.Address <> LA Then CountThisItem = CountThisItem + 1
Loop While rng_FindRange.Address <> LA
Else
CountThisItem = 0
End If
End Function
I am creating hierarchies and need to outline them in the format on the right-hand side. It would be a lot easier if I could simply outline the hierarchy in one column and automatically have it expand (left -> right in the sample).
A few considerations:
Within the first column, the start of a new hierarchy will always be the value 'A'
Hierarchies can range from 2-10 children in length
Any thoughts?
Type the letters in column A only, start each new sequence with the word HEADER. Then run the macro and the expansions should be created.
Sub expand()
Dim ws As Worksheet
Set ws = ActiveSheet
Dim cell As Range, cellHeader As Range
Dim irow As Integer, i As Integer
Dim iCount As Integer, iLast As Long
' find last row in col A
iLast = ws.Range("A" & Rows.Count).End(xlUp).Row
'scan down the sheet
For Each cell In ws.Range("A1:A" & iLast)
If UCase(cell) = "DIRECT" Then
' remember the header line
Set cellHeader = cell
With cellHeader
.BorderAround xlContinuous
.Font.Bold = True
End With
ElseIf Len(cell) > 0 Then
cell.BorderAround xlContinuous
' start of sequence
If cell = "A" Then
irow = 1
iCount = 0
End If
' add header value
With cellHeader.Offset(0, irow)
.Value = "L" & irow
.Font.Bold = True
.BorderAround xlContinuous
End With
' copy cell diagonally upwards
If irow > 1 Then
For i = 1 To irow - 1
cell.Offset(-i, i) = cell.Value
cell.Offset(-i, i).BorderAround xlContinuous
Next
End If
' check max children
iCount = iCount + 1
If iCount > 10 Then
MsgBox "Children count > 10", vbCritical, "Error"
Exit Sub
End If
irow = irow + 1
End If
Next
MsgBox "Expansion Complete", vbInformation
End Sub
You do not answer my questions and I cannot wait, anymore...
Please test the next code, which works based on the thowe assumptions: Your hierarchies in discussion have all the time a kind of header (Direct in column A:A and L1 in B:B). This, or an empty row sets the bottom part of the hierarchy.
Here's the code:
Sub HierarchyArrangeMultipleR()
Dim sh As Worksheet, i As Long, j As Long, lastR As Long, lastH As Long
Dim arrI As Variant, arrTr As Variant, colN As Long, k As Long, h As Long
Set sh = ActiveSheet 'please, use here your worksheet
lastR = sh.Range("A" & sh.Rows.count).End(xlUp).Row
For k = 1 To lastR
If lastH > 0 Then k = lastH + 1
If k >= lastR Then Exit For
Start:
If sh.Range("A" & k).Value = "Direct" And sh.Range("B" & k).Value = "L1" Then
For i = 1 To 10
If sh.Range("A" & k + i).Value = "Direct" Or _
sh.Range("A" & k + i).Value = Empty Then
lastH = k + i - 1: Exit For
End If
Next i
For h = 3 To lastH - k
sh.Cells(k, h) = "L" & h - 1
Next h
Else
k = k + 1: GoTo Start
End If
arrI = sh.Range("A" & k + 1 & ":A" & lastH).Value
ReDim arrTr(1 To UBound(arrI) - 1)
colN = 1
For i = k To lastH - 2
For j = 1 To UBound(arrTr) 'lastH - i + k - 2
arrTr(j) = arrI(j, 1)
Next j
colN = colN + 1
sh.Range(sh.Cells(k + 1, colN), sh.Cells(lastH + 1 - colN, colN)).Value = WorksheetFunction.Transpose(arrTr)
Next i
Erase arrTr
Next k
End Sub
I try to find a vba solution for the following problem:
I have two columns and try to group column1 in a comma separate way to have less rows.
e.g.
example:
I tried this, and it worked - but It take too long (about 300.000 Rows). Is there any better solution that task?
*Its just one part of my macro
For Each r In fr
If st = "" Then
st = Application.WorksheetFunction.Clean(Trim(ws.Cells(r.row, "L").Value))
Else
If Not IsInArray(Split(st, ","), ws.Cells(r.row, "L").Value) Then
st = st & ", " & Application.WorksheetFunction.Clean(Trim(ws.Cells(r.row, "L").Value))
End If
End If
If usrCheck = True Then
If str = "" Then
str = Application.WorksheetFunction.Clean(Trim(ws.Cells(r.row, "A").Value))
Else
If Not IsInArray(Split(str, ","), ws.Cells(r.row, "A").Value) Then
str = str & ", " & Application.WorksheetFunction.Clean(Trim(ws.Cells(r.row, "A").Value))
End If
End If
End If
Next
Maybe using Dictionary would be fast. What about:
Sub Test()
Dim x As Long, lr As Long, arr As Variant
Dim dict1 As Object: Set dict1 = CreateObject("Scripting.Dictionary")
Dim dict2 As Object: Set dict2 = CreateObject("Scripting.Dictionary")
With Sheet1 'Change accordingly
'Return your last row from column A
lr = .Cells(.Rows.Count, 1).End(xlUp).Row
'Get array and loop through it
arr = .Range("A2:B" & lr).Value
For x = LBound(arr) To UBound(arr)
dict1(arr(x, 2)) = arr(x, 2)
Next
'Loop through dictionary filling a second one
For Each Key In dict1.keys
For x = LBound(arr) To UBound(arr)
If arr(x, 2) = Key Then dict2(arr(x, 1)) = arr(x, 1)
Next x
.Range("F" & .Cells(.Rows.Count, 6).End(xlUp).Row + 1) = Key
.Range("G" & .Cells(.Rows.Count, 7).End(xlUp).Row + 1) = Join(dict2.Items, ", ")
dict2.RemoveAll
Next
End With
End Sub
This will get you all unique items from column A though, so if there can be duplicates and you want to keep them, this is not for you =)
Try also this, please. It works only in memory and on my computer takes less then 3 seconds for 300000 rows. The range must be filtered, like in your picture. If not, the filtering can also be easily automated.
Private Sub CondensData()
Dim sh As Worksheet, arrInit As Variant, arrIn As Variant, i As Long
Dim arrFinal() As Variant, lastRow As Long, Nr As Long, El As Variant
Dim strTemp As String, k As Long
Set sh = ActiveSheet
lastRow = sh.Cells(sh.Rows.count, "A").End(xlUp).Row
arrIn = sh.Range("B2:B" & lastRow + 1).Value
'Determine the number of the same accurrences:
For Each El In arrIn
i = i + 1
If i >= 2 Then
If arrIn(i, 1) <> arrIn(i - 1, 1) Then Nr = Nr + 1
End If
Next
ReDim arrFinal(Nr, 1)
arrInit = sh.Range("A2:B" & lastRow).Value
For i = 2 To UBound(arrInit, 1)
If i = 1 Then
strTemp = arrInit(1, 1)
Else
If arrInit(i, 2) = arrInit(i - 1, 2) Then
If strTemp = "" Then
strTemp = arrInit(i, 1)
Else
strTemp = strTemp & ", " & arrInit(i, 1)
End If
Else
arrFinal(k, 0) = arrInit(i - 1, 2)
arrFinal(k, 1) = strTemp
k = k + 1: strTemp = ""
End If
End If
Next i
sh.Range("C2:D" & lastRow).Clear
sh.Range("C2:D" & k - 1).Value = arrFinal
sh.Range("C:D").EntireColumn.AutoFit
MsgBox "Solved..."
End Sub
It will return the result in columns C:D
I have product codes: (they are in C column of active sheet)
DO-001
DO-002
DO-003
DO-004
And I have big list of data: (they are in C column of "Sheet1")
41300100_DO-001_14215171
41300104_DO-001_14215173
K1_ISK_41300661_DO-002_13190369
NP_41533258_DO-003_14910884
DO-003_DD_44_ddd
And I want to count how many times do the product codes appear in the list of data. So the result for this case'd be: (result is H column of active sheet)
DO-001 2
DO-002 1
DO-003 2
DO-004
I have done this with this code:
Sub CountcodesPLC()
Dim i, j As Integer, icount As Integer
Dim ldata, lcodes As Long
icount = 0
lcodes = Cells(Rows.Count, 3).End(xlUp).Row
ldata = Worksheets("Sheet1").Cells(Rows.Count, 3).End(xlUp).Row
For i = 10 To lcodes
For j = 2 To ldata
If InStr(Worksheets("Sheet1").Range("C" & j), Range("C" & i)) <> 0 Then
icount = icount + 1
End If
Next j
If icount <> 0 Then
Range("H" & i).Value = icount
End If
icount = 0
Next i
End Sub
But I want to change it, so if the list of data contains some key words like "NP", "ISK", then not to count them, or if the first part of the data is the code then also not to count them, so the result for this example would be:
DO-001 2
DO-002
DO-003
DO-004
Also, I'll have around 1.000 product codes, and around 60.000 strings of data.
Will my code crash?
Seems your code is OK. But if you want to match only the first part of string (a'ka StartsWith), i'd change only this line:
If InStr(Worksheets("Sheet1").Range("C" & j), Range("C" & i)) <> 0 Then
to:
If Worksheets("Sheet1").Range("C" & j) Like Range("C" & i) & "*" Then
For further details, please see: Wildcard Characters used in String Comparisons
Use Dictionnary
Dim Dict As Scripting.Dictionary
Set Dict = New Scripting.Dictionary
Arr = Split("refer your text here", "_")
For I = LBound(Arr) To UBound(Arr)
If Dict.Exists(Arr(I)) Then
Dict(Arr(I)) = Dict(Arr(I)) + 1 'increment
Else
Dict.Add Arr(I), 1
End If
Next I
This may be OTT for the requirement but should work quite quickly.
Public Sub Sample()
Dim WkSht As Worksheet
Dim LngRow As Long
Dim AryLookup() As String
Dim VntItem As Variant
'We put what we want to search into an array, this makes it a lot quicker to search
Set WkSht = ThisWorkbook.Worksheets("Sheet1")
ReDim AryLookup(0)
LngRow = 1
Do Until WkSht.Range("A" & LngRow) = ""
If AryLookup(UBound(AryLookup, 1)) <> "" Then ReDim Preserve AryLookup(UBound(AryLookup, 1) + 1)
AryLookup(UBound(AryLookup, 1)) = Trim(UCase(WkSht.Range("A" & LngRow)))
LngRow = LngRow + 1
Loop
Set WkSht = Nothing
'Then we go down the list and check the array against each item
Set WkSht = ActiveSheet
LngRow = 1
Do Until WkSht.Range("A" & LngRow) = ""
WkSht.Range("B" & LngRow) = 0
For Each VntItem In AryLookup()
'This looks for the match without any of the exclusion items
If (InStr(1, VntItem, Trim(UCase(WkSht.Range("A" & LngRow)))) <> 0) And _
(InStr(1, VntItem, "NP") = 0) And _
(InStr(1, VntItem, "ISK") = 0) Then
WkSht.Range("B" & LngRow) = WkSht.Range("B" & LngRow) + 1
End If
Next
LngRow = LngRow + 1
Loop
Set WkSht = Nothing
MsgBox "Done"
End Sub
Basically, the 60,000 data strings will go into an array in memory, then the array will be searched against the 1,000 products. Searching in memory should be quick.
One thing I would raise is the exclusion method may produce false positives.
For example, excluding NP will exclude: -
NP_41533258_DO-003_14910884
NPA_41533258_DO-003_14910884
41533258_ANP_DO-003_14910884
You may want to think about the method overall.
Have you considered an array formula, not sure how it will perform vs code, but, you could do something along these lines, where list is in A and prod numbers in B
=SUM(IF(NOT(ISERR(SEARCH(B1 & "_",$A$1:$A$5,1)))*(ISERR(SEARCH("NP_",$A$1:$A$5,1))),1,0))
Where "NP" would be replaced by a range containing the exclusions, I've left as NP to show what's happening.
The code would be like this. But I don't know the speed.
Sub test()
Dim vDB, vLook, vSum(), Sum As Long
Dim Ws As Worksheet, dbWs As Worksheet
Dim s As String, sF As String, sCode As String
Dim i As Long, j As Long, n As Long
Set dbWs = Sheets("Sheet1")
Set Ws = ActiveSheet
With Ws
vLook = .Range("a1", .Range("a" & Rows.Count).End(xlUp))
End With
With dbWs
vDB = .Range("c1", .Range("c" & Rows.Count).End(xlUp))
End With
n = UBound(vLook, 1)
ReDim vSum(1 To n, 1 To 1)
For i = 1 To n
sF = Split(vLook(i, 1), "-")(0)
sCode = Replace(vLook(i, 1), sF, "")
Sum = 0
For j = 1 To UBound(vDB, 1)
s = vDB(j, 1)
If Left(s, Len(sF)) = sF Or InStr(s, "NP") Or InStr(s, "ISK") Then
Else
If InStr(s, sCode) Then
Sum = Sum + 1
End If
End If
Next j
If Sum > 0 Then
vSum(i, 1) = Sum
End If
Next i
Ws.Range("h1").Resize(n) = vSum
End Sub
I am running sub where it compares two cells (B and D/or string Received) from one sheet ("DATA") with two cells (C, H) from another sheet ("Incoming_report"), and if they match it transposes I, G cells from Incoming to Data.
It is done by combining two cells from Incoming_report sheet and writing new value in Z column for example "123456" from C and H to f.e. "123456Received" (there another 5 statuses (Received, Rejected, Sent...., but I need the ones only that was Received)
Then I am taking from Data Sheet B column for example 123456 and only Received (there might be another 5 statuses, but I only need the one that was received).
That makes all sence to me and works pretty good, but I have to work with more than 500k rows in each sheet. What happens - 500,000 times two cells are combined and searched in Z column in another sheet among another 500,000 for possible match, if nothing found then N/A, and then 2 combination, 3rd, 4th... till 500,000. I added the Display status bar and I see how slowly it goes (only 900 rows per minute, so for one minor mapping it would take more than 10 hours). Here is the sub itself, can anyone share ideas how to improve it to make it work faster? Thanks a million.
Sub incoming_fetch()
Application.ScreenUpdating = False
Dim incr As Long
Dim x As String
n = Sheets("Data").Range("A" & Rows.Count).End(xlUp).Row
Z = Sheets("Incoming_report").Range("D" & Rows.Count).End(xlUp).Row
For i2 = 2 To Z
Sheets("Incoming_report").Range("Z" & i2).Value = Sheets("Incoming_report").Range("C" & i2).Value & Sheets("Incoming_report").Range("H" & i2).Value
Next i2
For i = 3 To n
Application.DisplayStatusBar = True
Application.StatusBar = i
x = Sheets("Data").Range("B" & i).Value & "Received"
If Sheets("Incoming_report").Range("Z:Z").Find(x, lookat:=xlWhole, LookIn:=xlFormulas) Is Nothing Then
Sheets("Data").Range("L" & i) = "N/A"
Sheets("Data").Range("M" & i) = "N/A"
Else
incr = Sheets("Incoming_report").Range("Z:Z").Find(x, lookat:=xlWhole, LookIn:=xlFormulas).Row
Sheets("DATA").Range("L" & i) = Sheets("Incoming_report").Range("I" & incr)
Sheets("DATA").Range("M" & i) = Sheets("Incoming_report").Range("G" & incr)
End If
Next i
End Sub
EDIT2: fixed source columns :
Sub incoming_fetch()
Dim i As Long, n As Long, z As Long, num As Long
Dim x As String
Dim shtIn As Worksheet, shtData As Worksheet
Dim dict As Object, arrC, arrH, arrG, arrI, v, arr, r1, r2
Dim t
Set dict = CreateObject("scripting.dictionary")
Set shtIn = Sheets("Incoming_report")
Set shtData = Sheets("Data")
n = shtData.Range("A" & Rows.Count).End(xlUp).Row
z = shtIn.Range("D" & Rows.Count).End(xlUp).Row
t = Timer
'get all values from Cols C, H, L, M
arrC = shtIn.Range(shtIn.Range("C2"), shtIn.Range("C" & z)).Value
arrH = shtIn.Range(shtIn.Range("H2"), shtIn.Range("H" & z)).Value
arrG = shtIn.Range(shtIn.Range("G2"), shtIn.Range("G" & z)).Value
arrI = shtIn.Range(shtIn.Range("I2"), shtIn.Range("I" & z)).Value
Debug.Print "Get Arrays: " & Timer - t
t = Timer
'create a lookup dictionary of all the ColC values
' (where ColH = "Received")
num = UBound(arrC, 1)
For i = 1 To num
v = arrC(i, 1)
If arrH(i, 1) = "Received" And Len(v) > 0 Then
dict(v) = Array(arrI(i, 1), arrG(i, 1))
End If
Next i
'free up some memory
Erase arrC: Erase arrH: Erase arrI: Erase arrG
Debug.Print "Filled dict: " & Timer - t
t = Timer
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
On Error GoTo haveError
For i = 3 To n
If i Mod 500 = 0 Then Application.StatusBar = i
x = shtData.Range("B" & i).Value
If dict.exists(x) Then
arr = dict(x)
r1 = arr(0)
r2 = arr(1)
Else
r1 = "N/A": r2 = "N/A"
End If
With shtData
.Range("L" & i) = r1
.Range("M" & i) = r2
End With
Next i
Debug.Print "Done: " & Timer - t
haveError:
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
End Sub