I'm having trouble with confirming if any cell in a specified range contains any value. Hoping someone can help me out with the syntax.
Thanks in advance
For i = 1 To DataRange.Rows.Count
CheckCells = If(Qty > 0 And WS1.Range("Sheet1!A" & i & ":Sheet1!Z" & i).Value <> "", "HasValue", "NoValue")
Next i
You could iterate over the cells to examine each one:
Dim r = xl.Range("A1", "D4")
Dim nCells = r.Cells.Count
Dim isAllBlank = True
For i = 1 To nCells
If DirectCast(r.Cells(i), Excel.Range).Value IsNot Nothing Then
isAllBlank = False
Exit For
End If
Next
checkCells = If(isAllBlank, "NoValue", "HasValue")
Where xl.Range is the range you need to check.
I tried to use range.SpecialCells(Excel.XlCellType.xlCellTypeBlanks), but it was a bit moody about it.
I was able to achieve what I wanted by using the following code.
For i = 1 To DataRange.Rows.Count
If xlApp.WorksheetFunction.CountA(WS.Range("Parts!Z" & R & ":Parts!AI" & R)) > 0 Then
CheckCells = "HasValue"
Else
CheckCells = "NoValue"
End If
Next i
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 extract a substring which has a random position from different strings. The substing is not a fixed value but a "T" and then four numberals e.g. T6000.
As you can see in this image there are a number of machines names where most of them contain a T number. The T number is also different in almost all of the cases. The column of the machines names is "E". First number (T6000) is in E16, last is in E25.
Using my code:
For Ipattern = 16 To NumofMachines + 15 Step 1
TNUMcell = Dsht.Range("E" & Ipattern).Value
'Verify if string contains a Tnum
TNUMLikeBoolean = TNUMcell Like "*T###*"
If TNUMLikeBoolean = True Then
Do Until TNUMdone = True
TNUMchar1 = InStr(TNUMcell, "T") + 1
TNUMcharV = Mid(TNUMcell, TNUMchar1)
TNUMchecknum = IsNumeric(TNUMcharV)
If TNUMchecknum = True Then
Dsht.Range("F" & Ipattern).Value = "T" & Mid(TNUMcell, TNUMchar1, 5)
TNUMdone = True
End If
Loop
Else
Dsht.Range("F" & Ipattern).Value = "NO T"
End If
Next Ipattern
It only fills in the first and the last cell of the 'export' range (F16:F25).
I have been searching for an answer quite some time. As I am (obviously) not a VBA expert.
What am I doing wrong? Why is not filling in the other values?
Thanks,
Wouter J
Try this code
Sub Test()
Dim r As Range, i As Long, c As Long
With CreateObject("VBScript.RegExp")
.Global = True
.Pattern = "T\d{4}"
For Each r In Range("E16", Range("E" & Rows.Count).End(xlUp))
c = 6
If .Test(r.Value) Then
For i = 0 To .Execute(r.Value).Count - 1
Cells(r.Row, c).Value = .Execute(r.Value)(i)
c = c + 1
Next i
End If
Next r
End With
End Sub
The problem is with your variable TNUMdone.
This is set to True on the first iteration of the loop and then never again set to False, so this code after Do Until TNUMdone = True never runs again.
At the start of your loop, just set TNUMdone to False and it should work:
For Ipattern = 16 To NumofMachines + 15 Step 1
TNUMdone = False
TNUMcell = Dsht.Range("E" & Ipattern).Value
...
I have a code that searches an excel fill for the word distance, takes the value of the cell next to it, paste it into a new cell, then sums all the cells up. Which works great, but i now need to find a way to only sum ever even row number. Does that make sense?
Sub Distance_Check()
Dim DistanceCheck As String
Dim DistanceNumber As String
Dim DistanceSum As String
Dim DistanceTotal As String
DistanceCheck = MsgBox("Would you like to check the distance?", vbYesNo)
If DistanceCheck = vbYes Then
If IsArray(fname) Then Workbooks.OpenText fname(1)
i = 1
findStr = "Distance"
Set foundCel = Range("A:A").Find(what:=findStr)
If Not foundCel Is Nothing Then
firstAddress = foundCel.Address
Do
Range("J" & i).Value = foundCel.Offset(0, 1).Value
Set foundCel = Range("A:A").FindNext(foundCel)
i = i + 1
Loop While Not foundCel Is Nothing And foundCel.Address <> firstAddress
End If
Set wkbSourceBook = ActiveWorkbook
DistanceNumber = i - 2
DistanceSum = WorksheetFunction.Sum(Range(Cells(2, 15), (Cells(DistanceNumber + 1, 15))))
DistanceTotal = DistanceSum / DistanceNumber
If DistanceNumber = Cells(2, 12) Then
MsgBox ("No error found wihin distance")
Else
MsgBox ("Error found with distance")
End If
Else
End If
Call Save_Data
End Sub
Would the way youd go about this be using a for loop on the
cells(DistanceNumber(j,+1)
Where j = 0,
j = j +2 ,
Until j > DistanceNumber,
Would that work? If so how would you go about it?
Thanks
A quick way to step through a loop in the desired increments is to use the Mod operator which divides two numbers and returns any remainder (e.g. 7 mod 2 = 1, as two sixes fit into seven, leaving one).
You can use the row property of the range you identify with the Find method, and since you want to jump by two the modulo should be zero:
If foundcel.Row Mod 2 = 0 Then Range("J" & i).value = foundcel.Offset(0, 1).Value
That said, there is a 'built in' way to step through a loop if using a For loop like this
For x = 2 to 10 Step 2
' Do stuff
Next x
You can also use this method to step backwards, e.g.
For x = 100 to 0 Step -10
' Do stuff backwards!
Next x
Below is my current Excel table:
I want to automatically generate the third column in yellow as a hierarchical view of all activities. I tried to solve this challenge with formulas but I am not sure that would be the best way to do it.
Has someone already faced and solved this requirement in Excel? Any advice/suggestions to guide me?
Many thanks and best regards!
You can paste this macro in the Worksheet's code Module and run it from there:
Sub CalculateHierarchy()
Dim rLevels As Range, rLevel As Range
Dim level As Integer, maxLevels As Integer, cur As Integer, i As Integer
Dim h As String, counts() As Integer
Set rLevels = Range("A2:A" & Range("A1").End(xlDown).Row)
maxLevels = WorksheetFunction.Max(rLevels)
ReDim counts(1 To maxLevels)
cur = 1
For Each rLevel In rLevels
level = rLevel.Value
If level > cur + 1 Then
rLevel.Activate
MsgBox "error at row " & rLevel.Row & " level increase by more than 1"
Exit Sub
End If
h = ""
counts(level) = counts(level) + 1
For i = 1 To level
h = h & "." & counts(i)
Next
h = Mid(h, 2)
For i = level + 1 To UBound(counts)
counts(i) = 0
Next
rLevel.Offset(, 2).Value = h
cur = level
Next
rLevel.Offset(0, 2).Interior.ColorIndex = 6
End Sub
Basically I have 7 cells that could be populated with text (b2, b4, b6, b8, b10, b12 and b14). I want to the code to check each of the cells to see if they have a value and send only the cells that do have a value in an email. For formatting purposes the cells pasted into the email need to have one empty cell in between and the cells need to be kept in the order they are in originally, just without the unnecessary blank cells.
I've never officially learned VBA I've only taught myself on a case by case scenario so there could be an easy solution that I'm missing. Often I can debug and find the problem but in this case Excel completely freezes and turns "Not Responding". I have a feeling that means I've got a loop somewhere unresolved but I don't really understand how. The code -seems- to run up until Range("A2").Value = Line(LineCount1). Any suggestions would be appreciated.
Public Sub SingleEmail()
Dim LineCount1 As Integer
Dim LineCount2 As Integer
Dim LineCount3 As Integer
Dim LineCount4 As Integer
Dim LineCount5 As Integer
Dim LineCount6 As Integer
Dim LineCount7 As Integer
Dim NumOfLines As Integer
Range("A2", "A14").ClearContents
LineCount1 = 2
Range("A2").Value = Line(LineCount1)
LineCount2 = 2 + LineCount1
Range("A4").Value = Line(LineCount2)
LineCount3 = 2 + LineCount2
Range("A6").Value = Line(LineCount3)
LineCount4 = 2 + LineCount3
Range("A8").Value = Line(LineCount4)
LineCount5 = 2 + LineCount4
Range("A10").Value = Line(LineCount5)
LineCount6 = 2 + LineCount5
Range("A12").Value = Line(LineCount6)
LineCount7 = 2 + LineCount6
Range("A14").Value = Line(LineCount7)
NumOfLines = Range("n3").Value
If Range("A2") <> "" Then
Range("A2", "A" & NumOfLines).Select
ActiveWorkbook.EnvelopeVisible = True
With ActiveSheet.MailEnvelope
.Introduction = ""
.Item.To = "personalemailaddress#Someplace.com"
.Item.CC = ""
.Item.Subject = "Email Subject"
.Item.send
End With
End If
End Sub
Function Line(ByRef LineCount As Integer) As String
Line = ""
Do While Line = "" Or LineCount < 13
If Range("B" & LineCount).Value <> "" Then
Line = Range("B" & LineCount).Value
Else
LineCount = LineCount + 2
End If
Loop
End Function
To answer your question:
If B4 has value and B2 is blank then this While loop become infinite. the LineCount is Stuck on 4, hence no overflow. That's why your code freezes.
Why are you running a loop in the first place. You can simply assign the values like this Range("A2:A14").Value =Range("B2:B14").Value
As per your comment, you need to use And operator in place of OR
Do While Line = "" And LineCount < 13 now the loop will exit if line <> "" or LineCount > 14