I am working on an excel problem that I feel will have to be based off duplicates. Basically if duplicate values are found ("A:A") then somehow group them as a variable and only populate the matching rows if atleast 1 negative number exists in ("B:B"). The same will apply to non duplicates as well where they should only populate if a negative number exists in Column B but I feel that can be done easily via formula
I have tried a few things but the main problem is identifying the duplicates as their own variable. When I create a function that behaves purely off highlighted duplicates,this would apply to all duplicates regardless of their individual text. This would be much simpler if summed but that is not the case. Below is an example of what I am going for
Problem:
IDs Trades
US9128 -500
US9128 750
EU9133 900
GD2104 -300
GD2104 150
FG5454 200
Expected:
IDs Trades
US9128 -500
US9128 750
GD2104 -300
GD2104 150
Open to other routes to this problem
Suppose your data is in column(A:B),Starting form row(1)
Try this Macro
Option Explicit
Sub test_me()
Dim obj As Object
Dim x, k%
Dim R%, C%
R = 2: C = 4
Dim lr%: lr = Cells(Rows.Count, 1).End(3).Row
Dim i%, j%
Range("d2").CurrentRegion.ClearContents
Set obj = CreateObject("System.Collections.SortedList")
For i = 2 To lr
obj.Add Cells(i, 2).Value, Cells(i, 1).Value
For j = i + 1 To lr
If Cells(j, 1) = Cells(i, 1) Then
obj.Add Cells(j, 2).Value, Cells(j, 1).Value
End If
Next j
x = obj.Count
If x = 1 Then GoTo NEXT_I
With Cells(R, C)
.Value = obj.GetByIndex(0): .Offset(, 1) = obj.Getkey(0)
.Offset(1) = obj.GetByIndex(x - 1): .Offset(1, 1) = obj.Getkey(x - 1)
End With
R = R + 2
NEXT_I:
obj.Clear
Next i
Set obj = Nothing
End Sub
Related
I have a macro with counter for unique values that met specific conditions. As you can see on the image, I have list of unique values in column F. Macro checks, if value is listed in column AE (can contain duplicated lines) and checks if there is no "OB" in column AH. Then returns how many values it found in cell K2. But I need this counter to also list these values in column AD, but I am struggling to make it happen. I checked many forums and managed to crash Excel twice already. Any ideas how to achieve it?
Dim myTbl As range, mStr As String, Miss As Long, xCol As Variant
Set myTbl = Sheets("OB").range("AE2") '
xCol = "AH"
mStr = ""
Set myTbl = range(myTbl, myTbl.End(xlDown).Offset(0, 1))
xCol = Cells(1, xCol).Column - myTbl.Cells(1, 1).Column + 1
For i = 1 To myTbl.Rows.count
If myTbl.Cells(i, 1) <> "" Then
If myTbl.Cells(i, xCol) <> "OB" And InStr(1, mStr, "##" & myTbl.Cells(i, 1), vbTextCompare) = 0 Then
mStr = mStr & "##" & myTbl.Cells(i, 1)
Miss = Miss + 1
End If
End If
Next i
If Miss > 0 Then
range("K2") = Miss & " still active"
range("K2").Font.ColorIndex = 46
Else
range("K2") = "None"
range("K2").Font.ColorIndex = 10
End If
Please, test the next code. It, also, is able to return how many occurrences per each Value x have been found (if more than one per each exist):
Sub ExtractUniqueCondValues()
Dim sh As Worksheet, lastR As Long, arr, i As Long, dict As Object
Set sh = Sheets("OB")
lastR = sh.Range("AE" & sh.rows.count).End(xlUp).row
arr = sh.Range("AE2:AH" & lastR).Value
Set dict = CreateObject("Scripting.Dictionary")
For i = 1 To UBound(arr)
If arr(i, 4) <> "OB" Then dict(arr(i, 1)) = dict(arr(i, 1)) + 1
Next i
sh.Range("K2").Value = dict.count
sh.Range("AD2").Resize(dict.count, 1).Value = Application.Transpose(dict.Keys)
End Sub
About occurrences per each 'Value x' element, it can return in an adiacent column 'Value 2| 1 andValue 4` | 2, for your picture case... Of course, if it may have relevance for your purpose. The dictionary already keeps this data.
Maybe using formulas is an option for you? See column G where the formula in G2 is the following and copied down.
=IF(COUNTIFS(AE:AE,F2,AH:AH,"<>OB")>0,F2,"")
Using Count or Countifs may be an option instead of VBA.
I am trying to add values from different sheets (Sheet 2 to 5) into my main sheet (Sheet 1). In Sheet 1 I want the cells to contain the right formula pointing to the different sheets (if possible).
Typically like this:
='Sheet2'!D5+'Sheet3'!D165
All my sheets have different products, but some sheets contain same products. So I want to search through them all and ADD them in my Main Sheet (Sheet 1).
Sub UpdateMainSheet()
' Kode for å Oppdatere Plukkeliste Alle Artikler Summert
Dim AktivtArk As String
Dim AktivtArkNavn As String
Dim K As Integer
Dim Count As Integer
'Line of code to delete old data in Main Sheet:
Worksheets("Sheet1").Range("A2:H10000").Clear
AktivtArkOverskrift = "List of Articles from Sheet 2 to 5"
'Creates Headline in Main Sheet:
eRow = Sheet1.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Row
Worksheets("Sheet1").Cells(eRow, 1) = AktivtArkOverskrift
Worksheets("Sheet1").Cells(eRow, 1).Font.Bold = True
'Script to check and gather data from the other sheets (Sheet 2, 3, 4 and 5):
For K = 2 To 5
'For loop to check each line in sheet "K"
For I = 2 To 1000
'If function to check if the cell I in column F is empty, if so it_jumps to next row and do the same check:
If Worksheets(K).Cells(I, 6) > 0 Then
Count = 0
'For loop to check if I already have a row in the Main Sheet with the article I'm checking:
For L = 2 To 1000
'If function to check if the articles have the same article number:
If Worksheets(K).Cells(I, 1) = Worksheets("Sheet1").Cells(L, 1) Then
'Line of code that are supposed to ADD the values that is currently in the Main Sheet, togheter with the value in Sheet K:
Worksheets("Sheet1").Cells(I, 4).Formula = Worksheets("Sheet1").Cells(I, 4) + Worksheets(K).Cells(L, 4)
End If
Next L
End If
Next I
Next K
End Sub
So what I need to fix in my code is this part (located furthest inside the For Loop):
Worksheets("Sheet1").Cells(I, 4).Formula = Worksheets("Sheet1").Cells(I, 4) + Worksheets(K).Cells(L, 4)
And make it create a formula in the wanted cell, that looks something like this:
='Sheet2'!D5+'Sheet3'!D165
It must be able to add another cell as well, since the Loop are running through several Sheets (Sheet 2 to 5) that may contain the same products.
I.e. I only want one line in my Main Sheet for each product.
I managed to find the solution in the end.
It seemed I had switched the L and I in som of the looping, which resulted in the values not to be added togheter.
The following code (I did not translate to English, but can do this if someone wants/need it) solved my issue, and gave me the values from Sheet 2 to 5 sorted by product in Sheet 1:
Sub OppdaterePlukkelisteSummert()
'Kode for å Oppdatere Plukkeliste Alle Artikler Summert
Dim AktivtArk As String
Dim AktivtArkNavn As String
Dim K As Integer
Dim Teller As Integer
Dim value1 As Integer
Dim value2 As Integer
'Sletter Plukklisten for å oppdatere og sortere på nytt:
Worksheets(1).Range("A2:H10000").Clear
'HENTING AV DATA FRA ARKET "K":
AktivtArk = "Artikler Summert fra Alle Ark"
AktivtArkOverskrift = "Artikler Summert fra Alle Ark"
'Setter inn Overskrift som Forteller kva ark utstyret kommer fra:
eRow = Sheets(1).Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Row
Worksheets(1).Cells(eRow, 1) = AktivtArkOverskrift
Worksheets(1).Cells(eRow, 1).Font.Bold = True
'Sjekker hvilke/hvilket rader/utstyr som skal plukkes, og legger det inn i "Ark1":
For K = 2 To 5
For I = 2 To 1000
If Worksheets(K).Cells(I, 6) > 0 Then
Teller = 0
For L = 2 To 1000
If Worksheets(K).Cells(I, 1) = Worksheets(1).Cells(L, 1) Then
value1 = Worksheets(1).Cells(L, 4)
value2 = Worksheets(K).Cells(I, 4)
Worksheets(1).Cells(L, 4) = value1 + value2
Worksheets(1).Cells(L, 6) = value1 + value2
Else
Teller = Teller + 1
End If
Next L
If Teller > 998 Then
eRow = Sheets(1).Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Row
For J = 1 To 11
Worksheets(1).Cells(eRow, J) = Worksheets(K).Cells(I, J)
Next J
Worksheets(1).Cells(eRow, 6).Font.Color = RGB(0, 150, 0)
Worksheets(1).Cells(eRow, 7).Font.Color = RGB(0, 150, 0)
End If
End If
Next I
Next K
Worksheets(1).Range("A2").Select
End Sub
I hope this can be useful for someone else :-)
All help and suggestion in the comments are appreciated!
I was going to illustrate with this simple example:
I = 1 'for example
For K = 2 To 5
Worksheets("Sheet1").Cells(I, 4).Value = Worksheets("Sheet1").Cells(I, 4).Value + _
WorksheetFunction.SumIf(Worksheets(K).Range("A:A"), "Bananas", Worksheets(K).Range("D:D"))
Next K
I have a table where user can insert multiple rows over multiple columns where some data is string and some numeric. I want to create a button such that when the user clicks it, it will create a new table on the same excel sheet but with some of the rows combined based on predefined condition.
Eg. The table "pre defined condition" states that alpha and gamma are similar and so on(it can many rows like this which show the conditions to combine rows..condition will always pertain to second row of the user defined table i.e table 1)...Table 1 will be created by a different user and he can enter as many rows as he wishes to. So using these 2 tables (Table 1 & Pre defined condition tabel) I want to create a new table which has certain rows combined with stringfrom two rows separated using "/" and numbers added.
The structure will remain the same for all tables.
Edit:One value in column 2 will always have same value in column 1.Basically column 2 is a dependent list(on column 1 ). There can be many pre -defined conditions and not just limited to 2 . Usually there won't be any duplicate values in column 2,but in case there are I want to combine them in a row at click of the button.
Table 1
A Alpha 100 1
B Beta 200 2
C Gamma 300 3
D Kappa 400 4
Pre Defined Condition
Alpha Gamma
Beta Kappa
Desired Output
A/C Alpha/Gamma 400 4
B/D Beta/Kappa 600 6
Assuming that your data starts in A2:D2 (A1:D1 left for titles), that you state two conditions (for example Alpha Gamma) in columns F and G (starting in the second row; first row left for titles), that there is a command button, and that the worksheet is named "Sheet1", the following code should do the trick.
Dim i As Integer
Dim j As Integer
Dim lLastRowPDC As Integer
Dim lLastRowData As Integer
Dim sConditions As String
Dim sOrigin As String
Dim sColumnA As String
Dim sColumnB As String
Dim iColumnC As Integer
Dim iColumnD As Integer
Private Sub CommandButton1_Click()
lLastRowPDC = Worksheets("Sheet1").Cells(2, 6).End(xlDown).Row 'Rows with Conditions, starting in the second row
lLastRowData = Worksheets("Sheet1").Cells(2, 1).End(xlDown).Row 'Rows with data, starting in the second row
For i = 2 To lLastRowPDC
sConditions = Worksheets("Sheet1").Cells(i, 6).Value & Worksheets("Sheet1").Cells(i, 7).Value 'create a string with the two conditions
sColumnA = ""
sColumnB = ""
iColumnC = 0
iColumnD = 0
For j = 2 To lLastRowData
sOrigin = Worksheets("Sheet1").Cells(j, 2).Value
If InStr(sConditions, sOrigin) > 0 Then
If InStr(sColumnA, Worksheets("Sheet1").Cells(j, 1).Value) = 0 Then
sColumnA = sColumnA & Worksheets("Sheet1").Cells(j, 1).Value & "/"
End If
If InStr(sColumnB, Worksheets("Sheet1").Cells(j, 2).Value) = 0 Then
sColumnB = sColumnB & Worksheets("Sheet1").Cells(j, 2).Value & "/"
End If
iColumnC = iColumnC + Worksheets("Sheet1").Cells(j, 3)
iColumnD = iColumnD + Worksheets("Sheet1").Cells(j, 4)
End If
Next j
sColumnA = Left(sColumnA, Len(sColumnA) - 1) 'remove last "/"
sColumnB = Left(sColumnB, Len(sColumnB) - 1) 'remove last "/"
Worksheets("Sheet1").Cells(i, 8).Value = sColumnA
Worksheets("Sheet1").Cells(i, 9).Value = sColumnB
Worksheets("Sheet1").Cells(i, 10).Value = iColumnC
Worksheets("Sheet1").Cells(i, 11).Value = iColumnD
Next i
End Sub
I am having trouble determining a way to enter a 1 or 0 into an adjacent cell to indicate whether or not a value is unique when working with a large dataset. I have read of multiple methods for accomplishing this, however none of them seem efficient for my purposes: I am using an instance of Excel 2010 (so I do not have the Distinct Count feature in PivotTables, and when I try to use PowerPivot it crashes my file due to processing limitations.
In this StackOverflow question: Simple Pivot Table to Count Unique Values there are suggestions to use SUMPRODUCT or COUNTIF, but when working with 50,000+ rows as I am, this causes terrible performance and a file size of ~35 MB instead of ~3 MB. I wanted to know if there is a better solution for a large, dynamic dataset whether it is a formula or VBA.
An example of what I would like to accomplish is (with the Unique column being the adjacent cell):
Name Week Unique
John 1 1
Sally 1 1
John 1 0
Sally 2 1
I attempted to script the same functionality of COUNTIF but with no success:
For Each Cell In ThisWorkbook.Worksheets("Overtime & Type Data").Range("Z2:Z" & DataLastRow)
If Worksheets("Overtime & Type Data").Cells(Cell.Row, 26) <> Worksheets("Overtime & Type Data").Cells(Cell.Row - 1, 26) Then
FirstCell = Cell.Row
End If
If (Worksheets("Overtime & Type Data").Range(Cells(FirstCell, 26), Cells(Cell.Row, 26)) = Worksheets("Overtime & Type Data").Range(Cells(Cell.Row, 26))) = True Then
Cell.Value = 1
Else
Cell.Value = 0
End If
Next Cell
This code ran on over 130,000 rows successfully in less than 3 seconds. Adjust the column letters to fit your dataset.
Sub tgr()
Const colName As String = "A"
Const colWeek As String = "B"
Const colOutput As String = "C"
Dim ws As Worksheet
Dim rngData As Range
Dim DataCell As Range
Dim rngFound As Range
Dim collUniques As Collection
Dim arrResults() As Long
Dim ResultIndex As Long
Dim UnqCount As Long
Set ws = ThisWorkbook.Sheets("Overtime & Type Data")
Set rngData = ws.Range(colName & 2, ws.Cells(Rows.Count, colName).End(xlUp))
Set collUniques = New Collection
ReDim arrResults(1 To rngData.Cells.Count, 1 To 1)
On Error Resume Next
For Each DataCell In rngData.Cells
ResultIndex = ResultIndex + 1
collUniques.Add ws.Cells(DataCell.Row, colName).Value & ws.Cells(DataCell.Row, colWeek).Value, ws.Cells(DataCell.Row, colName).Value & ws.Cells(DataCell.Row, colWeek).Value
If collUniques.Count > UnqCount Then
UnqCount = collUniques.Count
arrResults(ResultIndex, 1) = 1
Else
arrResults(ResultIndex, 1) = 0
End If
Next DataCell
On Error GoTo 0
ws.Cells(rngData.Row, colOutput).Resize(rngData.Cells.Count).Value = arrResults
End Sub
One approach is to sort by Name and Week. Then you can determine Unique for any row by comparing with the previous row.
If you need to preserve the order, you could first write a column of Index numbers (1, 2, 3, ...) to keep track of order. After calculating Unique, sort by Index to restore the original order.
The whole process could be done manually with relatively few steps, or automated with VBA.
I'm not sure how well this will work with 50000 values, but it goes through ~1500 in about a second.
Sub unique()
Dim myColl As New Collection
Dim isDup As Boolean
Dim myValue As String
Dim r As Long
On Error GoTo DuplicateValue
For r = 1 To Sheet1.UsedRange.Rows.Count
isDup = False
'Combine the value of the 2 cells together
' and add that string to our collection
'If it is already in the collection it errors
myValue = Sheet1.Cells(r, 1).Value & Sheet1.Cells(r, 2).Value
myColl.Add r, myValue
If isDup Then
Sheet1.Cells(r, 3).Value = "0"
Else
Sheet1.Cells(r, 3).Value = "1"
End If
Next
On Error GoTo 0
Exit Sub
DuplicateValue:
'The value is already in the collection so put a 0
isDup = True
Resume Next
End Sub
Just about any bulk operation will beat a loop involving worksheet cells. You might be able to trim the time down a bit by performing all of the calculations in memory and only returning the values back to the worksheet en masse when it is complete.
Sub is_a_dupe()
Dim v As Long, vTMP As Variant, vUNQs As Variant, dUNQs As Object
Debug.Print Timer
On Error GoTo bm_Uh_Oh
Set dUNQs = CreateObject("Scripting.Dictionary")
With Worksheets("Sheet1")
vTMP = .Range(.Cells(2, 1), .Cells(Rows.Count, 2).End(xlUp)).Value2
ReDim vUNQs(1 To UBound(vTMP, 1), 1 To 1)
For v = LBound(vTMP, 1) To UBound(vTMP, 1)
If dUNQs.Exists(Join(Array(vTMP(v, 1), vTMP(v, 2)))) Then
vUNQs(v, 1) = 0
Else
dUNQs.Add Key:=Join(Array(vTMP(v, 1), vTMP(v, 2))), _
Item:=vTMP(v, 2)
vUNQs(v, 1) = 1
End If
Next v
.Cells(2, 3).Resize(UBound(vUNQs, 1), 1) = vUNQs
End With
Debug.Print Timer
bm_Uh_Oh:
dUNQs.RemoveAll
Set dUNQs = Nothing
End Sub
Previous experience tells me that the variety of data (as well as hardware, etc) will impact timing the process but in my random sample data I received these elapsed times.
50K records ..... 0.53 seconds
130K records .... 1.32 seconds
500K records .... 4.92 seconds
The code I have once worked to add/delete groups of rows (requirements). I needed to modify the code so that if the 1st row of the group met certain criteria (i.e, the requirement was not one we wanted to consider), (1) we would not count it and (2), we would hide the group (current and subsequent 2 rows). This all works fine.
The problem is that now that I incorporated these changes, I get an error in another section of the code and for the life of me I cannot figure out why. I have stepped through this and am extremely frustrated. I am reaching out for help, and am hoping someone can see my error(!)
We calculate the start and finish row numbers within a grouping, and store these calculations in Arrays called "Start" and "Finish." I use the ReDim statement to initialize my arrays, because I thought that could be part of the problem, but no.
Any insight as to why my "subscripts are out of range" would be appreciated. I have traced through the logic, investigated this error, and read about the syntax/usage of VBA arrays. I don't know what else to do. Thanks in advance. Here are the relevant lines:
Sub Button1_Click()
Cells.Select
Selection.ClearOutline
If Cells.EntireRow.Hidden Then Cells.EntireRow.Hidden = False
Dim Start() As Integer
Dim Finish() As Integer
Dim p As Integer, q As Integer
ReDim Start(0, 50)
ReDim Finish(0, 50)
The following is embedded in logic that loops through all the rows in the spreadsheet:
i = 1
For Row = 4 To Cells(1, 6).Value - 1
If Begin Then
If Cells(Row, 3).Interior.ColorIndex = 44 Then
Start(i) = Row + 1
j = Cells(Row, 2).Value
Begin = False
End If
Else
If Cells(Row, 2).Value = j + 1 Or Cells(Row, 2).Interior.ColorIndex = 37 Then
Finish(i) = Row - 1
Begin = True
i = i + 1
Row = Row - 1
End If
End If
Next
The block I changed is as follows (code I added is last block where I attempt to hide rows). It precedes the previous. I am wondering how my change could have affect the above(?!)
If Cells(Row, 5).Value = "Requirement" Then
Range(Cells(Row, 4), Cells(Row, 4)).Interior.ColorIndex = 40
Rows(Row).Font.Bold = True
Rows(Row).Font.Italic = False
Rows(Row).Font.ColorIndex = 1 'Black
If Cells(Row - 3, 4).Value = "" Then 'this is requirement #1
Cells(Row, 4).Value = 1
Else
Cells(Row, 4).Value = Cells(Row - 3, 4).Value + 1
End If
p = Row
q = p + 2
Rows(p & ":" & q).Select
If Cells(p, 19).Value = "4" Then
Selection.EntireRow.Hidden = True
Else
Selection.EntireRow.Hidden = False
End If
Redim Start(0,50) makes the array dimensions 0 to 0, 0 to 50 i.e. a 2d array.
This means that when you call the array you need to provide parameters for both dimensions I.E: Start(0,i) or Finish(0,i). Calling Start(i) will result in the error you mentioned.
The easiest way to get rid of the error is to change your Redim lines to
ReDim Start(50)
ReDim Finish(50)
which is what I assume you meant to do in the first place.
Note: Based upon the format you used, you may have been meaning to do Start(0 to 50) and Finish(0 to 50) initially. The comma in the dimensioning indicates another dimension instead of a separation between lower and upper bounds.