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
Related
I have a table in an active worksheet.
I am trying to:
Scan Columns(A:M) of Row 6 to see if all cells are empty
If yes, then scan Columns (N:R) of Row 6 to see if all cells are empty
If 2. is false, then copy above row's Columns (A:I) in Row 6
Repeat 1-3 but on Row 7
This process should repeat until the rows of the table end.
I would like to incorporate ActiveSheet.ListObjects(1).Name or something similar to duplicate the sheet without having to tweak the code.
How I can make this as efficient and as risk free as possible? My code works but it's really too much.
Sub CopyPasteRow()
Dim lr As Long
Dim x As Long
Dim y As Long
Dim a As Long
lr = Cells(Rows.Count, 1).End(xlUp).Row
a = 0
For x = 6 To lr
For y = 1 To 13
If Not IsEmpty(Cells(x, y)) Then
a = a + 1
End If
Next y
If a = 0 Then
For y = 14 To 18
If Not IsEmpty(Cells(x, y)) Then
a = a + 1
End If
Next y
Else
a = 0
End If
If a <> 0 Then
For y = 1 To 13
Cells(x, y).Value = Cells(x - 1, y).Value
Next y
End If
a = 0
Next x
End Sub
This is the final code based on #CHill60 code. It got me 99% where I wanted.
Sub CopyPasteRow()
Dim lr As Long
Dim x As Long
Dim a As Long
Dim r As Range, r2 As Range, r3 As Range
lr = Cells(Rows.Count, 1).End(xlUp).Row
For x = 6 To lr
'check columns A to M for this row are empty
Set r = ActiveSheet.Range("A" & CStr(x) & ":M" & CStr(x))
'check columns N to R for this row are empty
Set r2 = ActiveSheet.Range("N" & CStr(x) & ":R" & CStr(x))
If WorksheetFunction.CountA(r) = 0 And WorksheetFunction.CountA(r2) <> 0 Then
'copy the data into columns A to M
Set r3 = ActiveSheet.Range("A" & CStr(x) & ":I" & CStr(x))
r3.Value = r3.Offset(-1, 0).Value
End If
Next x
End Sub
Instead of looking at individual cells, look at Ranges instead. Consider this snippet of code
Sub demo()
Dim x As Long
For x = 6 To 8
Dim r As Range
Set r = Sheets(1).Range("A" & CStr(x) & ":M" & CStr(x))
Debug.Print r.Address, MyIsEmpty(r)
Next x
End Sub
I have a function for checking for empty ranges
Public Function MyIsEmpty(rng As Range) As Boolean
MyIsEmpty = WorksheetFunction.CountA(rng) = 0
End Function
I use this because the cell might "look" empty, but actually contain a formula.
Note I've explicitly said which sheet I want the Cells from - users have a habit of clicking places other than where you think they should be! :laugh:
Edit after OP comment:
E.g. your function might look like this
Sub CopyPasteRow()
Dim lr As Long
Dim x As Long
Dim a As Long
Dim r As Range, r2 As Range
lr = Cells(Rows.Count, 1).End(xlUp).Row
For x = 6 To lr
a = 0
'check columns A to M for this row are empty
Set r = Sheets(1).Range("A" & CStr(x) & ":M" & CStr(x))
If Not MyIsEmpty(r) Then
a = a + 1
End If
If a = 0 Then
'check columns N to R for this row are empty
Set r2 = Sheets(1).Range("N" & CStr(x) & ":R" & CStr(x))
If Not MyIsEmpty(r2) Then
a = a + 1
End If
Else
a = 0
End If
If a <> 0 Then
'copy the data into columns A to M
'You might have to adjust the ranges here
r.Value = r2.Value
End If
Next x
End Sub
where you have a source range and a target range - you appear to be putting the values in the previous row so my value of r is probably wrong in this example - you could use r.Offset(-1,0).Value = r2.Value
I'm also not sure what you are trying to do with the variable a If that is meant to be a "flag" then consider using a Boolean instead - it only has the values True or False
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 have gone crazy with vba projects around the house and helping my wife upping her reports to the next level. I’m having troubles putting down to VBA what I’m thinking. If anyone has felt my pain please shed some light on the actual script that would help me over this hump. Summary might be comparing cell value for certain text using InStr and if doesn't exist the appending characters to the right end. I can append and run thru one cycle of the loop but get confused with trying to write the logic I'm thinking.
Alittle background on the report: One row equals one reservation. Within that row there is a column labeled “Nights”. This column is filtered for any reservation with more than “1” Night. Example: could be 3 nights, 6 nights, and 10 nights doesn’t matter. I have a macro that sorts these reservations and splits the one reservation into multiple rows totaling the number value in the “Nights” column. Basically, copying and inserting the rows next to each other. While this filtered is still applied (SpecialVisibleCells Only). Now I have another column labeled “ResNumber”. With 3, 6, or 10 rows split out the “ResNumber” column is the same number. I’m tasked with walking down this ‘ResNumber” column and appending a “-1” for the first row. A “-2” for the second reservation “-3” for the third and possibly a forth “-4” Until the last row of the copied for that one reservation group. Then the cycle (loop) starts again on the next group or block of rows. Same procedure.
Dim lnrow As Integer
Dim llrow As String
Dim rownuml As Integer 'row checker
Dim colnuml As String 'column checker
Dim count As Integer
Dim total As String 'Value of reservation's "Nights" column Offset(,17)
Dim startnum As Integer 'Start number for counter
Dim actcell As String 'Activecell
startnum = 1
With sh
llrow = .Cells(.Rows.count, 2).End(xlUp).row
If llrow = "" Then Exit Sub
.Cells(2, 2).Resize(llrow - 1).SpecialCells(xlCellTypeVisible).Select
For lnrow = 2 To llrow
rownuml = ActiveCell.row
colnuml = ActiveCell.Column
total = ActiveCell.offset(, 17).Value
For count = 1 To total
rownuml = ActiveCell.row
colnuml = ActiveCell.Column
actcell = ActiveCell.Value
'Compares row 1 and checks resNumber value for "-1" if none exist it appends.
If InStr(ActiveCell.Value, "-1") = 0 Then
ActiveCell.Value = ActiveCell.Value & "-1"
Else
GoTo nexrow
End If
'Compares row 2 and checks resNumber value of above cell.
If InStr(ActiveCell.offset(-1, 0).Value, "-1") = 0 Then
Resume Next
If InStr(ActiveCell.Value, "-2") = 0 Then
ActiveCell.Value = ActiveCell.Value & "-2"
GoTo nexrow
End If
'to jump out of loop nexrow
'ActiveCell moves one row down.
ActiveCell.offset(1, 0).SpecialCells(xlCellTypeVisible).Select
rownuml = ActiveCell.row 'just checking row number
colnuml = ActiveCell.Column 'just checking column number
'since 1st reservation is already in the DB startnum starts at # 1. The counter
startnum = startnum + count
Next count
Next
End With
Try:
Option Explicit
Sub test()
Dim LastRow As Long, Times As Long, Counter As Long, i As Long, y As Long
Dim strNumber As String
With ThisWorkbook.Worksheets("Sheet1")
LastRow = .Cells(.Rows.Count, "B").End(xlUp).Row
For i = 2 To LastRow
strNumber = .Range("B" & i).Value
Times = Application.WorksheetFunction.CountIf(.Range("B2:B" & LastRow), strNumber)
If Times > 1 Then
Counter = 1
For y = 2 To LastRow
If strNumber = .Range("B" & y).Value Then
.Range("B" & y).Value = strNumber & " - " & Counter
.Range("D" & y).Value = 1
Counter = Counter + 1
End If
Next y
End If
Next i
End With
End Sub
Results:
I have a long list of DOM Types which have a name. For example Other, After School Activities, Arts & Culture etc. Each of these column names have a corresponding value. For example Other is 30, Aboriginal Studies is 1. What I'm trying to do is in a new column assign the proper value to each of these columns. The catch is that some columns can have multiple names separated via ;#. How would I be able to accomplish this, separating the columns with multiple names with a comma. I want it to look like this
Name Value
----- -----
Music 36
Learning Resources 32
After-School Activities;#Competitions 3,9
Assuming your names are in Column A and your values are in Column B.
This will output the split names in Column C and your split values in `Column D.
Option Explicit
Sub Work_Sub()
Dim ws As Worksheet: Set ws = ThisWorkbook.Sheets("Sheet1")
Dim LR As Long, iName, iValue, iCell As Range
Dim j As Long, c As Long
LR = ws.Range("A" & ws.Rows.Count).End(xlUp).Row
c = 1
For Each iCell In ws.Range("A2:A" & LR)
If InStr(iCell, ";#") Then
iName = Split(iCell, ";#")
iValue = Split(iCell.Offset(, 1), ",")
If UBound(iName) = UBound(iValue) Then
For j = LBound(iName) To UBound(iName)
ws.Range("C" & c) = iName(j)
ws.Range("D" & c) = iValue(j)
c = c + 1
Next j
Else
ws.Range("C" & c) = "Unmatched splits"
End If
iName = ""
iValue = ""
Else
iCell.Offset(0, 2).Value = iCell.Value
iCell.Offset(0, 1).Value = iCell.Offset(0, 3).Value
c = c + 1
End If
Next iCell
End Sub
Not Tested. Probably over kill - just ran with the first method that came to mind
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)