I'm trying to create a macro which is supposed to check for a number of range to find out if there are multiple items separated by semicolon ; within certain cells. If it finds one then the macro will count how many times that sign ; has appeared in each cell:
For example, in Range("A1") that sign has appeared 3 times:
apple;orange;guava;malta
I've tried so far:
Sub DistributeItemsToColumns()
Dim cel As Range
For Each cel In Range("A1:L4")
If InStr(cel, ";") > 0 Then
Debug.Print cel 'can't think further
End If
Next cel
End Sub
Try:
Option Explicit
Sub test()
Dim LastRow As Long, i As Long, arr As Variant
Dim NumberOfOccu As Long
With ThisWorkbook.Worksheets("Sheet1")
'Find last row of column A
LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
'Loop from row 1 to lastrow
For i = 1 To LastRow
If InStr(.Range("A" & i).Value, ";") Then
'Number of characters
NumberOfOccu = InStr(.Range("A" & i).Value, ";")
arr = Split(.Range("A" & i).Value, ";")
.Range("C" & i).Resize(, UBound(arr) + 1) = arr
End If
Next i
End With
End Sub
Results:
Related
I need to auto number rows if adjacent cell is not blank using VBA.
any one from below codes works perfectly , except if it counter blank cells.
as always, your support is much appreciated.
this the expected output
Sub Fill_Serial_Numbers_Option1()
Dim LastRow As Long
LastRow = Cells(Rows.count, "B").End(xlUp).Row
If LastRow > 2 Then
Range("A3:A" & Application.Max(2, LastRow)) = Evaluate("ROW(A1:A" & LastRow & ")")
End If
End Sub
Sub Fill_Serial_Numbers_Option2()
Dim LastRow As Long
LastRow = Cells(Rows.count, "B").End(xlUp).Row
If LastRow > 2 Then
With Range("A3:A" & LastRow)
.Cells(1, 1).value = 1
.DataSeries Rowcol:=xlColumns, Type:=xlLinear, Step:=1, Trend:=False
End With
End If
End Sub
Please, test the next code:
Sub testCountNonBlanks()
Dim sh As Worksheet, lastR As Long, arr, arrA, count As Long, i As Long
Set sh = ActiveSheet
lastR = sh.Range("B" & sh.rows.count).End(xlUp).row: count = 1
If lastR <= 2 Then Exit Sub
arr = sh.Range("B2:B" & lastR).value 'place the range in an array for faster iteration
arrA = sh.Range("A2:A" & lastR).value
For i = 1 To UBound(arr)
If arr(i, 1) <> "" Then arrA(i, 1) = count: count = count + 1
Next i
sh.Range("A2").Resize(UBound(arrA), 1).value = arrA
End Sub
If a formula (written in VBA) is allowed, you can use the next variant:
Sub testCountByFormula()
Dim sh As Worksheet, lastR As Long, rngB As Range
Set sh = ActiveSheet
lastR = sh.Range("B" & sh.rows.count).End(xlUp).row
Set rngB = sh.Range("B2:B" & lastR)
sh.Range("A2:A10").Formula = "=IF(B2<>"""",COUNTA(" & rngB.Address & ")-COUNTA(" & rngB.Address(0, 1) & ")+1,"""")"
End Sub
You don't need a macro to accomplish this. Assuming all you care about is blank or not, then you can use a formula like this in cell A9. =Counta($B$1:$B9) If you have formulas you can try to leverage something with COuntif.
You can use a loop from the first row to the last one, something like this:
Sub Fill()
Dim LastRow As Long
Dim Count As Integer
Dim Row As Integer
Count = 0
Row = 1
LastRow = Cells(Rows.Count, "B").End(xlUp).Row
Do While Row <= LastRow
If Not (Cells(Row, 2) = "") Then
Count = Count + 1
Cells(Row, 1) = Count
End If
Row = Row + 1
Loop
End Sub
I need some help with comparing values from one column to another and delating it.
so far I have this:
Sub DelateDuplicates()
delArray = Sheets("Save").Range("B1:B") ' saved values
toDelate = Sheets("Validation").Range("B2:B").Value ' values to be checked and delated
lastRow = toDelate.Range("B1000").End(xlUp).Row ' last row
Firstrow = toDelate.Range("B2").End(xlDown).Row ' First row
Dim i As Long
For Lrow = lastRow To Firstrow Step -1
With Worksheets("Validation").Cells(Lrow, "A")
For i = 0 To UBound(delArray) ' arrays are indexed from zero
If Not IsError(.Value) Then
If .Value = delArray(i) Then
.EntireRow.Delete
Exit For
End If
End If
Next
End With
Next Lrow
End Sub
And I do have an error.
"1004 "Application-defined or Object-defined error" "
I have spent 2 days trying to figure it out so far no luck.
Any help will be appreciated.
I modified your code little bit. You can define your first rows and last row the want you want, I have kept it simple for the sake of concept
Option Explicit
Sub DelateDuplicates()
Dim Lrow As Long
Dim delarray()
With Worksheets("Save")
delarray = .Range("B1:B" & .Cells(.Rows.Count, "B").End(xlUp).Row).Value
End With
Dim i As Long
Dim lastrow As Long
Dim firstrow As Long
firstrow = 1
With Worksheets("Validation")
lastrow = .Cells(.Rows.Count, "A").End(xlUp).Row
For Lrow = lastrow To firstrow Step -1
For i = 1 To UBound(delarray)
If Not IsError(.Cells(Lrow, "A").Value) Then
If .Cells(Lrow, "A").Value = delarray(i, 1) Then
.Cells(Lrow, "A").EntireRow.Delete
Exit For
End If
End If
Next i
Next Lrow
End With
End Sub
You can avoid loops within loops by using a Dictionary Object
Option Explicit
Sub DeleteDuplicates()
Dim wsSave As Worksheet, wsValid As Worksheet
Dim iLastRow As Long, iFirstRow As Long, i As Long, n As Long
Dim dict As Object, key, cell As Range
With ThisWorkbook
Set wsSave = .Sheets("Save")
Set wsValid = Sheets("Validation")
End With
Set dict = CreateObject("Scripting.Dictionary")
' get values to delete from Column B
For Each cell In wsSave.Range("B1", wsSave.Cells(Rows.Count, "B").End(xlUp))
key = Trim(cell)
If Len(key) > 0 Then
dict(key) = cell.Row
End If
Next
' scan Validation sheet and delete matching from Save
With wsValid
iFirstRow = .Cells(2, "B").End(xlDown).Row
iLastRow = .Cells(Rows.Count, "B").End(xlUp).Row
For i = iLastRow To iFirstRow Step -1
key = .Cells(i, "A")
If dict.exists(key) Then
.Rows(i).Delete
n = n + 1
End If
Next
End With
' resutl
MsgBox n & " rows deleted between row " & _
iFirstRow & " and " & iLastRow, vbInformation
End Sub
Code is used to remove current format, removing format based on cell value = 3 in column A
Sub Format1()
Dim I As Long
Dim LastRow As Long
Dim lrowno As Long
Application.ScreenUpdating = False
LastRow = Range("B" & Rows.count).End(xlUp).Row
For lrowno = 4 To LastRow
If Range("A" & lrowno).Value = 3 Then
Range("H" & lrowno, "I" & lrowno).ClearFormats
End If
lrowno = lrowno + 4
Next lrowno
MsgBox ("Report is Generated")
End Sub
To improve speed you should reduce the amount of cell read/write actions to a minimum. Therefore you can read the whole column A into an array (to check the values there) and collect all the ranges that you want to clear format in a variable RangeToClear.
Never mess with a counter variable lrowno = lrowno + 4 in a For loop. Either use a Do loop where you can increas the counter yourself or use Step 5 to make Next increase by 5 instead by 1.
Option Explicit
Public Sub FormatReport()
Dim ws As Worksheet
Set ws = ThisWorkbook.Worksheets("Sheet1") 'specify your sheet
Dim LastRow As Long
LastRow = ws.Cells(ws.Rows.Count, "B").End(xlUp).Row
Dim ValuesOfColumnA() As Variant 'read column A into an array for faster data access!
ValuesOfColumnA = ws.Columns(1).Value
Dim RangeToClear As Range
Dim iRow As Long
For iRow = 4 To LastRow Step 5
If ValuesOfColumnA(iRow, 1) = 3 Then 'checking the array is much faster than checking the cell!
If RangeToClear Is Nothing Then 'first range to clear
Set RangeToClear = ws.Range("H" & iRow, "I" & iRow)
Else 'append/union all the other ranges to clear
Set RangeToClear = Application.Union(RangeToClear, ws.Range("H" & iRow, "I" & iRow))
End If
End If
Next iRow
'if something to clear was found then clear
If Not RangeToClear Is Nothing Then
RangeToClear.ClearFormats
End If
MsgBox "Report is Generated"
End Sub
Hello I am new to VBA and I have an excel sheet as shown in the image below and I want to run through each row until the last row to remove the characters in front of "/".
The following is my VBA code. However, my code could only work on one cell currently and I am not sure how do I change it to a For Loop to run through all the rows until the last row. Also, there are certain cells that does not contain the "/" and I just want it to be an empty cell. I need some help on how could I work on this? Thank you really appreciate if anyone would be able to assist me with this.
Sub String()
' String
Dim stringOriginal As String
stringOriginal = Range("A2").Value
Dim indexOfThey As Integer
indexOfThey = InStr(1, stringOriginal, "/")
Dim finalString As String
finalString = Right(stringOriginal, Len(stringOriginal) - indexOfThey)
Range("A2").Value = finalString
End Sub
Try following sub
Sub StringOperation()
Dim lRow As Long
Dim Rng As Range
lRow = Cells(Rows.Count, 1).End(xlUp).Row
For Each Rng In Range("A1:A" & lRow)
If (InStr(1, Rng, "/")) > 0 Then
Rng = Right(Rng, Len(Rng) - InStr(1, Rng, "/"))
End If
Next
End Sub
Edit: To empty cells that doesn't contain / use below codes.
Sub StringOperation()
Dim lRow As Long
Dim Rng As Range
lRow = Cells(Rows.Count, 1).End(xlUp).Row
For Each Rng In Range("A1:A" & lRow)
If (InStr(1, Rng, "/")) > 0 Then
Rng = Right(Rng, Len(Rng) - InStr(1, Rng, "/"))
Else
Rng = ""
End If
Next
End Sub
I have a Sheet with columns A through F. I'm looking for the program to run through all the rows (Is there a way for it to only do active rows?) and check if D1 & E1 & F1 are blank, then hide the row (and so on).
Here's what I have which doesn't really work too well....
Sub Celltest2()
Dim rw As Range, cel As Range
Dim i As Integer
Dim celset As Range
For Each rw In Sheets("Phonelist").Range("D2:F5000").Rows
For Each cel In rw.Cells
If Len(cel.Text) = 0 Then
cel.EntireRow.Hidden = True
End If
Next
Next
End Sub
Try the code below:
Sub Celltest2()
Dim rw As Range, cel As Range
Dim i As Integer
Dim celset As Range
Dim LastRow As Long
With Sheets("Phonelist")
' find last row with data in Columns "D, "E" and "F" >> modify to your needs
LastRow = WorksheetFunction.Max(.Cells(.Rows.Count, "D").End(xlUp).Row, _
.Cells(.Rows.Count, "E").End(xlUp).Row, _
.Cells(.Rows.Count, "F").End(xlUp).Row)
For Each rw In .Range("D2:F" & LastRow).Rows
If WorksheetFunction.CountA(Range("D" & rw.Row & ":F" & rw.Row)) = 0 Then
rw.EntireRow.Hidden = True
End If
Next rw
End With
End Sub
Option 2: You can replace the loop above (the one that starts with For Each rw In .Range("D2:F" & LastRow).Rows) with the following loop:
For i = 2 To LastRow
If WorksheetFunction.CountA(Range("D" & i & ":P" & i)) = 0 Then
Rows(i).EntireRow.Hidden = True
End If
Next i