Following is part of my program which does the follwoing function
It will look into column K and column L and create tabs according to the combinations. For example if column K has a cell value "Apple" and column L has one cell value "Orange" it will create a tab 1) Apple - Orange
The new tab will have all the rows with this combination
So once complete the running of macro , the whole data will get divided to different tabs according to the K - L combination
My problem is it is giving a run time error when entire column K or entire column L has only one value. For example if entire K column has 10 rows and all column k cells has value Apple it will give error. same goes for column L.
Dim m As Integer
Dim area As Range
Count = Range("K:K").SpecialCells(xlLastCell).Row
ActiveSheet.Range("K2:K" & Count).AdvancedFilter Action:=xlFilterCopy,
CopyToRange:=ActiveSheet.Range("Z2"), Unique:=True
Columns(26).RemoveDuplicates Columns:=Array(1)
Count1 = Range("L:L").SpecialCells(xlLastCell).Row
ActiveSheet.Range("L2:L" & Count1).AdvancedFilter Action:=xlFilterCopy,
CopyToRange:=ActiveSheet.Range("Y2"), Unique:=True
Columns(25).RemoveDuplicates Columns:=Array(1)
Dim arrayv As String
Dim Text1 As String
Dim arrayv1 As String
last = Range("Z2").End(xlDown).Row
arrayv = WorksheetFunction.Transpose(Sheets(1).Range("Z2:Z" & last).Value)
last1 = Range("Y2").End(xlDown).Row
arrayv1 = WorksheetFunction.Transpose(Sheets(1).Range("Y2:Y" & last1).Value)
Columns(26).EntireColumn.Delete
Columns(25).EntireColumn.Delete
Dim i As Long, j As Long
Dim flag As Variant
flag = 1
A = 1
s = 2
For c = 1 To UBound(arrayv1)
For t = 1 To UBound(arrayv)
Sheets.Add().Name = "Sheet" & s
ActiveSheet.Move After:=Sheets(ActiveWorkbook.Sheets.Count)
With Worksheets("Sheet1")
j = 2
.Rows(1).Copy Destination:=Worksheets("Sheet" & s).Range("A" & 1)
flag = 1
For i = 2 To Count
If .Cells(i, 11).Value = arrayv(t) Then
If .Cells(i, 12).Value = arrayv1(c) Then
Text = .Cells(i, 15).Value
flag = 0
.Rows(i).Copy Destination:=Worksheets("Sheet" & s).Range("A" & j)
j = j + 1
End If
End If
Next i
If flag = 1 Then
Sheets("Sheet" & s).Delete
Else
Text1 = Left(Text, 4)
Error line when column K has only one value
arrayv = WorksheetFunction.Transpose(Sheets(1).Range("Z2:Z" & last).Value)
Error line when column L has only one value
arrayv1 = WorksheetFunction.Transpose(Sheets(1).Range("Y2:Y" & last1).Value)
If there is only one value Y2 or Z2 downwards then using the Range,End property with an xlDirection of xlDown is going to reference row 1,048,576. The WorksheetFunction.Transpose method has a limit of 65,536. Anything exceeding this limit will result in,
Run-time error '13':Type mismatch.
Change the direction of the last-row-seek to look up from the bottom with xlUp.
last = Range("Z" & rows.count).End(xlUp).Row
arrayv = WorksheetFunction.Transpose(Sheets(1).Range("Z2:Z" & last).Value)
last1 = Range("Y" & rows.count).End(xlUp).Row
arrayv1 = WorksheetFunction.Transpose(Sheets(1).Range("Y2:Y" & last1).Value)
Related
I am struggling with changing counter in my macro. I just started my VBA adventure and spend whole day checking forums and tried many codes, but nothing is working.
I have a code which checks lots of conditions in table. In column F I have listed unique values. In column AE I have the same values, but some of them are duplicated, like in 2 or 3 lines. Now my code checks if value from column F exists in column AE and then checks other conditions like if there is "OB" in column AH and some more conditions. Then it counts how many values it found, but it counts duplicates as well. I need to change it to count only unique values from column AH. So lets say if value X is duplicated in AE2 and AE4 and both of them have "OB" in column AH, then counter shows only 1. Can somebody please explain me how to do it?
So if you look at the example, I have a list of unique values in column F. Column AE contain the same values, but in duplicated lines. 1st part of macro, for example, checks if value in column AE has "OB" in column AH and shows counter in J2. But now it shows 7, because it found 7 lines with values with "OB" in AH, but I need it to show 3, because the values are duplicated. Later macro checks if value has "OB" in column AH and if is different than 0 in column AM. Then it shows 2nd counter in K2. Right now it shows 3, because it found 3 lines with two conditions, but I need it to show 1, because it is the same value.
My code:
Dim lr1 As Long
lr1 = Cells(Rows.count, "F").End(xlUp).Row
Dim lr2 As Long
lr2 = Cells(Rows.count, "AE").End(xlUp).Row
Dim count As Long
Dim counter As Long
Dim x As Long
Dim y As Long
'••••••••••••••••• CHECK IF MATERIAL IS USED IN ACTIVE BOM •••••••••••••••••
'Loop in both ranges
For x = 3 To lr1
For y = 3 To lr2
If range("F" & x) = range("AE" & y) Then
'If material is set to OB
If UCase(range("AH" & y)) = "OB" Then
'And is used in BoM
If range("AO" & y) <> "" Then
'And BoM is not OB
If UCase(range("AP" & y)) <> "OB" Then
'Add to counter
count = count + 1
' range("F" & x).Interior.ColorIndex = 3
End If
End If
End If
End If
Next y
Next x
'Display results in J2
If count > 0 Then
range("J2") = count & " found"
range("J2").Font.Color = vbRed
Else
range("J2") = "None"
range("J2").Font.ColorIndex = 10
End If
'••••••••••••••••• CHECK IF MATERIAL IS ON STOCK •••••••••••••••••
'Loop in both ranges
For x = 3 To lr1
For y = 3 To lr2
If range("F" & x) = range("AE" & y) Then
'If material is set to OB
If UCase(range("AH" & y)) = "OB" Then
'And is on stock
If range("AM" & y) <> "0" Then
'Add to counter
counter = counter + 1
End If
End If
End If
Next y
Next x
'Display results in K2
If counter > 0 Then
range("K2") = counter & " on stock"
range("K2").Font.Color = vbRed
Else
range("K2") = "None"
range("K2").Font.ColorIndex = 10
End If
Here your are. The code first checks if the value in column AE is existing in the list of unique values and if column AH = "OB".
If this unique value has not been added to the unique collection, it will be added and the Unique count is increased, else it is ignored.
Function Condition1()
Dim ws As Worksheet: Set ws = Worksheets("Sheet1")
Dim uniqueRange As Range: Set uniqueRange = ws.Range("F2:F9")
Dim checkList As Collection
Dim i As Integer
Dim UniqueCounter As Integer
Set checkList = New Collection
For i = 2 To 15
Dim findStr As String
findStr = ws.Cells(i, "AE")
If Not uniqueRange.Find(findStr, LookIn:=xlValues) Is Nothing And ws.Cells(i, "AH") = "OB" Then 'Check if Value exists in master, if not ignore
Dim keyExists As Variant
On Error Resume Next
keyExists = Empty
keyExists = checkList(findStr)
On Error GoTo 0
If IsEmpty(keyExists) Then
UniqueCounter = UniqueCounter + 1
checkList.Add findStr, findStr
End If
End If
Next
Condition1 = UniqueCounter
End Function
In Column A of Sheet 1, I have a list of serial numbers which contain duplicates. I want to delete all duplicates and instead come up with a history column which captures all the information of the adjacent cells with regards to that serial number. The logic of my script goes like this: 1) Filter all distinct serial numbers into a new sheet 2) For each cell in new sheet, find all matching cells in sheet 1 3) If they match then copy adjacent columns information and create an new column with new matching information 4) The more serial duplicates are, the bigger the "history" cell of that serial number is going to have
Here is a screenshot of what I'm trying to do:
https://imgur.com/a/KEn0RIP
When I use "FindPN.Interior.ColorIndex = 3", the program does fine, finding all the 1's in the column and coloring them red. I just want to copy each the 3 cells' values that are adjacent to each '1' in Column A. I have used a Dictionary to create a dynamic variable to spit out the final cell that I want, but when I run the program, I am having problems understanding how the place the variables in the FindNext loop to spit out each different B2, C2, and D2.
Sub FindPN1() 'simplified script finding all the 1's in Sheet 1
Dim I, J, K, L, Atotal As Integer
Dim FindPN, FoundPN As Range
Dim UniqueValue As Range
Dim strStatus, strDate, strComments As Object
Atotal = Sheets(1).Range("A" & Rows.Count).End(xlUp).Row
With Sheets(1)
For I = 2 To Atotal
Set FindPN = Sheets(1).Columns(1).Find(1, LookIn:=xlValues)
If Not FindPN Is Nothing Then
Set FoundPN = FindPN
Set strStatus = CreateObject("Scripting.Dictionary")
For J = 1 To Atotal
strStatus(J) = Range("B" & I).Value
Next
Set strComments = CreateObject("Scripting.Dictionary")
For K = 1 To Atotal
strComments(K) = Range("C" & I).Value
Next
Set strDate = CreateObject("Scripting.Dictionary")
For L = 1 To Atotal
strDate(L) = Range("D" & I).Value
Next
Range("A15").Value = strDate(1)
'FindPN.Interior.ColorIndex = 3
Do
Set FindPN = .Columns(1).FindNext(After:=FindPN)
If Not FindPN Is Nothing Then
strStatus(J) = Range("B" & I).Value
strComments(K) = Range("C" & I).Value
strDate(L) = Range("D" & I).Value
'FindPN.Interior.ColorIndex = 3
Range("B15").Value = strDate(3)
If FindPN.Address = FoundPN.Address Then Exit Do
Else
Exit Do
End If
Loop
End If
Next
End With
The problem I am having is not knowing how to store my variables and having them spit out the 'History' Cell the way that I want. I have been practicing by going inside the loop to see where each variable gets defined but it seems like the strDate is always spitting out the date corresponding to the first 1.
You can make this much simpler - use a single dictionary and loop over the rows.
Add new Id's (and their "history" value) where they don't exist: if an id is already in the dictionary then append the new piece of history to the existing value.
When done, loop over the dictionary and write out the keys and the values.
Sub CombineRows()
Dim i As Long, h, k, lastRow As Long
Dim dict As Object, wsSrc As Worksheet
Set wsSrc = Sheets(1)
lastRow = wsSrc.Range("A" & Rows.Count).End(xlUp).Row
Set dict = CreateObject("Scripting.Dictionary")
For i = 2 To lastRow
With Sheets(1).Rows(i)
k = .Cells(1).Value
h = .Cells(2).Value & "|" & _
.Cells(4).Text & "|" & _
.Cells(3).Value
If dict.exists(k) Then
dict(k) = dict(k) & vbLf & h
Else
dict.Add k, h
End If
End With
Next i
DumpDict dict, Sheets(2).Range("A1")
End Sub
'write out dictionary content starting at "rng"
Sub DumpDict(dict As Object, rng As Range)
Dim c As Range, k
Set c = rng.Cells(1)
For Each k In dict.keys
c.Value = k
c.Offset(0, 1).Value = dict(k)
Set c = c.Offset(1, 0)
Next k
End Sub
I am very new to coding with it, and what appears below probably looks quite horrible.
What this code currently does is do an instr search for all 3 required values appearing in a single, and absolutely defined (for test purposes), row of another table, in a separate worksheet. Copies the A cell value from that row, pastes it into the cell next to the source table row, currently being searched, and colour codes it with a green fill.
What I want it to do, is be aware that there is a whole other table of data in the other worksheet, and have it search row by row for all 3 required values matching in a given row.
Once it gets an exact hit, I want it to output the A cell value for the row that has been confirmed to be a match of all 3 required values.
The table in the other sheet is dynamic, in that it increases or decreases in total number of rows day be day.
Is anyone kind enough to be able to help me with this?
Now, here is my novice mishmash of code:
Private Sub Match_Click()
Dim i As Integer, row As Integer, narrative1 As String, transDate As Date,
amount As Double, result As String
row = 2
i = 1
narrative1 = Worksheets("Sheet2").Range("D" & row)
transDate = Worksheets("Sheet2").Range("B" & row)
amount = Worksheets("Sheet2").Range("J" & row)
Do While Cells(i, 1).Value <> ""
If narrative1 > "" Then
If InStr(1, UCase(Worksheets("Sheet1").Range("D22")), UCase(narrative1)) And
InStr(1, Worksheets("Sheet1").Range("B22"), transDate) And InStr(1,
Worksheets("Sheet1").Range("H22"), amount) Then
result = Worksheets("Sheet1").Range("A3").Value
Else
result = ""
End If
End If
i = i + 1
If Worksheets("Sheet2").Range("A" & row).Value = "" Then result = ""
Worksheets("Sheet2").Range("K" & row).Value = result
If result <> "" Then Worksheets("Sheet2").Range("K" & row).Interior.Color =
RGB(198, 224, 180)
If Worksheets("Sheet2").Range("A" & row).Value = "" Then
Worksheets("Sheet2").Range("K" & row).Interior.ColorIndex = xlNone
row = row + 1
narrative1 = Worksheets("Sheet2").Range("D" & row)
transDate = Worksheets("Sheet2").Range("B" & row)
amount = Worksheets("Sheet2").Range("J" & row)
Loop
End Sub
I think the following code will do what you expect, I've commented it to let you know what its doing (I haven't tested it, but I'm pretty sure it will do the job):
Private Sub Match_Click()
Dim i As Long 'These should be Long instead of Integer, as Excel has more cells than Integer has values.
Dim row As Long
Dim LastRow As Long
Dim LastRow2 As Long
Dim narrative1 As String
Dim transDate As String
Dim amount As Double
Dim result As String
Dim val1 As Integer
Dim val2 As Integer
Dim val3 As Integer
LastRow2 = Worksheets("Sheet2").Cells(Worksheets("Sheet2").Rows.Count, "A").End(xlUp).row 'get the lastrow of Sheet2
LastRow = Worksheets("Sheet1").Cells(Worksheets("Sheet1").Rows.Count, "A").End(xlUp).row 'get the lastrow of Sheet1
For i = 1 To LastRow2 'loop from row 1 to last on Sheet2
narrative1 = Worksheets("Sheet2").Range("D" & i) 'get the variables to compare
transDate = Worksheets("Sheet2").Range("B" & i)
amount = Worksheets("Sheet2").Range("J" & i)
For x = 1 To LastRow ' loop through row 1 to last on Sheet1
If narrative1 <> "" Then
val1 = InStr(Worksheets("Sheet1").Cells(x, 4).Value, narrative1) 'number 4 represents column D
val2 = InStr(Worksheets("Sheet1").Cells(x, 2).Value, transDate) 'number 2 represents column B
val3 = InStr(Worksheets("Sheet1").Cells(x, 8).Value, amount) 'number 8 represents column H
If val1 > 0 And val2 > 0 And val3 > 0 Then 'if all three have been found
result = Worksheets("Sheet1").Cells(x, 1).Value 'get result
Worksheets("Sheet2").Range("K" & LastRow2 + 1).Value = result 'paster result into next free row on Sheet2 column K
If Worksheets("Sheet2").Cells(x, 1).Value <> "" Then Worksheets("Sheet2").Range("K" & LastRow2 + 1).Interior.ColorIndex = 4
Else
result = ""
End If
End If
Next x
Next i
End Sub
Hi I'm trying to create a loop that identifies a specific string in column "B", and SUMs up the values in column "D" of the same row. So far I've been able to identify the "cash" but now I don't know how to describe column "D" of the SAME row and sum it up. Please help!
Below is what I've got so far for this loop.
Dim CD As Long
Dim text As String
Dim Z As Long
CD = 0
For Z = 1 To Range("B" & Rows.Count).End(xlUp).Row
text = Range("B" & Z).Value
If Left(text, 4) = "Cash" Then
Sum....
You could certainly do something like:
For Z = 1 To Range("B" & Rows.Count).End(xlUp).Row
text = cells(Z,2).Value
If Left(text, 4) = "Cash" Then
Sum.... Zum = Zum + cells(Z,4).value
However, the computation could be done with a simple worksheet formula
=SUMIF(B:B,"cash*",D:D)
Following the code you have provided, this would be what you are looking for:
Sub calculateSum()
Dim CD As Long
Dim text As String
Dim Z As Long
'Create a variable to store the sum and set its value to 0.
Dim sum As Double
sum = 0
CD = 0
For Z = 1 To Range("B" & Rows.Count).End(xlUp).Row
text = Range("B" & Z).Value
If Left(text, 4) = "Cash" Then
'Increase the sum by the value stored in column D on the same row.
sum = sum + Range("D" & Z).Value
End If
Next Z
'Display the final result (sum).
MsgBox "Sum: " & sum
End Sub
first time poster, long time reader.
Apologies if this is hard to follow.
I have a spreadsheet which has a list of first names and last names. What I am wanting to do is take all of the first names which have the same last name and place them, evenly(ish) and separated by a comma, into the 3 reference columns in the same spreadsheet for example;
Example of Completed Sheet
I would like to do this in VBA because there are 200+ names and growing, and later the code will use this information to create and populate more workbooks.
So far, what I have works for all last names which have 3 or less first names (ie; one per column) but I cannot get it to work for last names where there are more than 3 first names.
My thought was to read all of the names into an array, split out the elements which have more than 3 names into another array, join these together separated by a comma, to then be transferred to the relevant column on the sheet.
However for some reason, I cannot get it to output more than one name into the column.
I have had a few attempts at this, but this is my latest attempt;
Private Sub cmdUpdate_Click()
Dim i As Long
Dim j As Long
Dim k As Long
Dim l As Long
Dim m As Long
Dim namesPerCol As Long
Dim strLastNameMatches As String
Dim arrNames() As String
Dim arrMultiNames(3) As String
Application.ScreenUpdating = False
With ActiveSheet
'Finds the last row with data in it
lngLastRow = .Cells(.Rows.count, "A").End(xlUp).Row
End With
'Sort the Columns
Columns("A:E").Sort key1:=Range("A1"), Header:=xlYes
'Loop through the LastNames
For i = 2 To lngLastRow
'Second loop through the LastNames
For j = 2 To lngLastRow
'If the last name matches
If Cells(i, 2).Value = Cells(j, 2).Value Then
'If the cell is empty then
If Range("C" & i).Value = "" Then
'Place the name in colA into colC
Range("C" & i).Value = Range("A" & j).Value
Else
'If the cell is not empty, then place a comma and space and then the value from colA
Range("C" & i).Value = Range("C" & i).Value & ", " & Range("A" & j).Value
End If
End If
Next j
Next i
For i = 2 To lngLastRow
strLastNameMatches = Range("C" & i).Value
arrNames = Split(strLastNameMatches, ", ")
If UBound(arrNames) > 2 Then
namesPerCol = UBound(arrNames) / 3
For l = 0 To 1
For k = LBound(arrNames) To namesPerCol
arrMultiNames(l) = arrNames(k) & ", "
Next k
Next l
For m = LBound(arrMultiNames) To UBound(arrMultiNames)
Select Case m
Case 0
Range("C" & i).Value = arrMultiNames(m)
Case 1
Range("D" & i).Value = arrMultiNames(m)
Case 2
Range("E" & i).Value = arrMultiNames(m)
End Select
Next m
Else
For j = LBound(arrNames) To UBound(arrNames)
Select Case j
Case 0
Range("C" & i).Value = arrNames(j)
Case 1
Range("D" & i).Value = arrNames(j)
Case 2
Range("I" & i).Value = arrNames(j)
End Select
Next j
End If
Next i
Application.ScreenUpdating = True
End Sub
Apologies for the poor quality coding, I will work on tiding it up once it is all working.
Any help I can get to get this code splitting out the names evenly across the three columns will be greatly appreciated
This task might be simpler if you could store your data into a more tree-like structure. There are many ways to do this; I've used the Collection object as it's easy to handle an unknown number of items. Basically, there are collections within a collection, ie one collection of first names for each last name.
The sample below uses very rudimentary distribution code (which is also hard-coded to a split of 3), but the point is that iterating through and down the tree is far simpler:
Dim lastList As Collection, firstList As Collection
Dim lastText As String, firstText As String
Dim data As Variant, last As Variant, first As Variant
Dim output() As Variant, dist(1 To 3) As Long
Dim str As String
Dim r As Long, c As Long, i As Long
'Read data into an array
With Sheet1
data = .Range(.Range("A1"), .Cells(.Rows.Count, "B").End(xlUp)).Value2
End With
'Create lists of unique lastnames containing the firstnames
Set lastList = New Collection
For r = 2 To UBound(data, 1)
firstText = CStr(data(r, 1))
lastText = CStr(data(r, 2))
Set firstList = Nothing
On Error Resume Next
Set firstList = lastList(lastText)
On Error GoTo 0
If firstList Is Nothing Then
Set firstList = New Collection
lastList.Add firstList, lastText
End If
firstList.Add firstText
Next
'Write results to sheet
ReDim output(1 To UBound(data, 1) - 1, 1 To 3)
For r = 2 To UBound(data, 1)
lastText = CStr(data(r, 2))
Set firstList = lastList(lastText)
'Calculate the distribution
dist(3) = firstList.Count / 3 'thanks #Comitern
dist(2) = dist(3)
dist(1) = firstList.Count - dist(2) - dist(3)
i = 1: c = 1: str = ""
For Each first In firstList
str = str & IIf(i > 1, ", ", "") & first
i = i + 1
If i > dist(c) Then
output(r - 1, c) = str
i = 1: c = c + 1: str = ""
End If
Next
Next
Sheet1.Range("C2").Resize(UBound(output, 1), UBound(output, 2)).Value = output