display only cells with value in Pop Up Form - excel

the macro below takes two cell values (from first and second column)
and displays the column and there cell content in a Pop up Form
Im trying to add the condition that only the column and cell value is displayed if the cell contains value.
something like that =IF(A1<>"",result,"")
but I dont know how to implement that for all cells not only for a specific one.
Option Explicit
Const rangeForSearch = "G2"
Const rowTitles = 4
Dim arrTmp
Dim lastRow As Long, lastColumn As Long
Dim textForSearch As String, textForSearch_withoutSpaces As String
Dim strTmp As String
Dim i As Long, j As Long
Sub searchPerson()
Application.ScreenUpdating = False
With ActiveSheet
textForSearch = .Range(rangeForSearch)
If textForSearch = "" Then
MsgBox "Input text in cell """ & rangeForSearch & """ and try again!", vbCritical
Application.ScreenUpdating = True
Exit Sub
End If
lastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
lastColumn = .Cells(rowTitles, .Columns.Count).End(xlToLeft).Column
If lastRow <= rowTitles Or lastColumn <= 2 Then
MsgBox "Dataset is wrong! Check it and try again!", vbCritical
Application.ScreenUpdating = True
Exit Sub
End If
arrTmp = .Range(.Cells(rowTitles, "A"), .Cells(lastRow, lastColumn))
End With
'---------------------------------------
textForSearch_withoutSpaces = Replace(textForSearch, " ", "")
For i = LBound(arrTmp, 1) + 1 To UBound(arrTmp, 1)
strTmp = Replace(arrTmp(i, 1) & arrTmp(i, 2), " ", "")
If StrComp(textForSearch_withoutSpaces, strTmp, vbTextCompare) = 0 Then Exit For
Next i
If i = UBound(arrTmp, 1) + 1 Then
strTmp = textForSearch & vbCrLf & vbCrLf & "No dataset!"
Else
strTmp = textForSearch
For j = 3 To lastColumn
strTmp = strTmp & vbCrLf & vbCrLf & arrTmp(1, j) & ": " & arrTmp(i, j)
Next j
End If
Application.ScreenUpdating = True
MsgBox strTmp, , "Result"
End Sub

maybe
For j = 3 To lastColumn
If Not IsEmpty(arrTmp(i, j)) Then strTmp = strTmp & vbCrLf & vbCrLf & arrTmp(1, j) & ": " & arrTmp(i, j)
Next j

Related

How Can I link the codes to Command Button?

I have a some part of the codes of a macro it's working below changing of the cell value. But I want to replace them as linking a command button + getting data from a closed workbook. Can someone help me about re-edit them?
Thank you for help!
Private Sub Worksheet_Change(ByVal Target As Range)
Dim Chck As Integer, Cnt As Integer
Dim Save As String
Dim Subjt As Integer
If Not Intersect(Range("A1"), Target) Is Nothing And Not Target = "" Then
With Workbooks("Data2.xlsm").Worksheets("Datas")
Application.EnableEvents = False
Worksheets("Sheet1").Cells.Clear
For Chck = 2 To .Cells(Rows.Count, "C").End(xlUp).Row
Select Case .Cells(Chck, "C")
Case "Number"
Subjt = Chck
Case ""
If Save <> "" Then
Save = "C" & Subjt & ":Q" & Subjt & Save
.Range(Save).Copy
Cnt = Worksheets("Sheet1").Range("A" & Rows.Count).End(xlUp).Row
If Cnt > 1 Then Cnt = Cnt + 2
Worksheets("Sheet1").Range("A" & Cnt).PasteSpecial
Save = ""
End If
Case Target
If .Cells(Chck, "B") = "Number" Then Save = Save & ", C" & Chck & ":Q" & Chck
End Select
Next
Application.EnableEvents = True
End With
End If
End Sub
Try this in a regular module:
EDIT: made a few fixes
Sub CopyDataValues()
Dim Chck As Long, Cnt As Long
Dim Save As String
Dim Subjt As Long, valA1
Dim ws1 As Worksheet, wsData As Worksheet
Set ws1 = ThisWorkbook.Worksheets("Sheet1")
Set wsData = Workbooks("Data2.xlsm").Worksheets("Datas")
Cnt = ws1.Range("A" & Rows.Count).End(xlUp).Row
Cnt = Cnt + 2
valA1 = ws1.Range("A1").Value
If Len(valA1) > 0 Then
With wsData
Application.EnableEvents = False
'ws1.Cells.Clear
For Chck = 2 To .Cells(Rows.Count, "C").End(xlUp).Row
Select Case .Cells(Chck, "C")
Case "NUMBER"
Subjt = Chck
Case ""
If Save <> "" Then
Save = "C" & Subjt & ":Q" & Subjt & Save
.Range(Save).Copy ws1.Range("A" & Cnt)
Cnt = Cnt + 2
Save = ""
End If
Case valA1
If .Cells(Chck, "B") = "REAL" Then
Debug.Print "matched " & valA1 & " on row " & Chck
Save = Save & ", C" & Chck & ":Q" & Chck
End If
End Select
Next
Application.EnableEvents = True
End With
End If
End Sub
Change Private Sub to Sub only and assign the macro to your related button.
For the workbook first, you have to create an excel object to get the closed workbook in it.

Updating For Each loop variable

The aim is to find the circularity between value in column c and all values obtained from updated "firstvalue" variable which are comma separated and stored in column "M".
Sub circular()
Dim rng As Range, rng2 As Range, firstvalue As String, secondvalue As String
Set sh = ThisWorkbook.Worksheets("Sheet1")
lr = sh.Range("C" & Rows.Count).End(xlUp).Row
For Each rng In sh.Range("C5:C" & lr) 'iterating over each cell in column "c" from C5 till lastrow "lr".
firstvalue = rng.Offset(0, 10).value 'Corresponding cell value which is comma seperated in column
"M" i:e after 10 columns from "C".
Dim n As Variant
For Each n In Split(firstvalue, ",") 'Looping through each value obtained from split function.
Set rng2 = sh.Range("C5:C" & lr).Find(Trim(n), LookIn:=xlValues) 'Finding that split value again
in column "C".
If Not rng2 Is Nothing Then 'if exists in column c then get.
secondvalue = rng2.Offset(0, 10).value 'corresponding cell values.
firstvalue = firstvalue & "," & secondvalue 'now first value is concatnated
with initial firstvalue
End If
Next n
MsgBox firstvalue
'Now i want to itterate over updated "firstvalue" in split function and this goes on in circular
fashion until rng value exists in firstvalue.
Next rng 'then change next rng and continue the above whole process for this value and so on.
End Sub
This code is working for initial firstvalue, can any one suggest any method to iterate over updated first value.
I'm not sure if I understand your goal exactly, but this code should find all predecessors for each task:
Sub circular()
Dim sh As Worksheet
Dim rTask As Range
Dim oCell As Range
Dim oFound As Range
Dim lr As Long, j As Long
Dim aPredecessors As Variant
Dim sCurTask As String
Dim secondValue As String
Set sh = ThisWorkbook.Worksheets("Sheet1")
lr = sh.Range("C" & Rows.Count).End(xlUp).Row
Set rTask = sh.Range("C5:C" & lr)
For Each oCell In rTask
sCurTask = Trim(oCell.Text)
aPredecessors = getPredecessors(Trim(oCell.Offset(0, 10).Text))
j = LBound(aPredecessors)
Do Until j > UBound(aPredecessors)
secondValue = aPredecessors(j)
If sCurTask = secondValue Then
ReDim Preserve aPredecessors(j)
Debug.Print "Task '" & sCurTask & "': Cyclic link '" & secondValue & "' for '" & Join(aPredecessors, ",") & "'!"
aPredecessors(j) = aPredecessors(j) & " !!!"
Else
If secondValue <> vbNullString Then
Set oFound = rTask.Find(secondValue, LookIn:=xlValues)
If oFound Is Nothing Then
ReDim Preserve aPredecessors(j)
Debug.Print "Task '" & sCurTask & "': Task '" & secondValue & "' for '" & Join(aPredecessors, ",") & "' not found!"
aPredecessors(j) = aPredecessors(j) & " ???"
Else
Call addNewTasks(aPredecessors, Trim(oFound.Offset(0, 10).Text))
End If
End If
End If
j = j + 1
Loop
oCell.Offset(0, 11).Value = Join(aPredecessors, ",")
Next oCell
End Sub
Function getPredecessors(sPredecessors As String)
Dim i As Long
Dim aTemp As Variant, sRes As String
Dim sTest As String
sRes = vbNullString
aTemp = Split(sPredecessors, ",")
For i = LBound(aTemp) To UBound(aTemp)
sTest = Trim(aTemp(i))
If InStr("," & sRes & ",", "," & sTest & ",") = 0 Then sRes = sRes & sTest & ","
Next i
If Len(sRes) > 1 Then sRes = Left(sRes, Len(sRes) - 1)
getPredecessors = Split(sRes, ",")
End Function
Sub addNewTasks(aData As Variant, sPredecessors As String)
Dim i As Long, uB As Long
Dim aTemp As Variant
Dim sTest As String, sValid As String
aTemp = Split(sPredecessors, ",")
If UBound(aTemp) >= 0 Then ' Not empty
sValid = "," & Join(aData, ",") & ","
For i = LBound(aTemp) To UBound(aTemp)
sTest = Trim(aTemp(i))
If sTest <> vbNullString Then
If InStr(sValid, "," & sTest & ",") = 0 Then
uB = UBound(aData) + 1
ReDim Preserve aData(uB)
aData(uB) = sTest
sValid = "," & Join(aData, ",") & ","
End If
End If
Next i
End If
End Sub

How to loop over conditions in countifs formula VBA

I have an Excel worksheet with a column full of COUNTIFS() formulas. For each one that evaluates to zero, I have to manually apply filters on the appropriate columns to find out at which step in the formula the result reached zero. What I want to do is write a macro to automate this a bit. For instance:
=COUNTIFS('Data'!A:A,"Yes",'Data'!B:B,"Yes",'Data'!C:C,"Yes")
If the count becomes zero as soon as the first condition is evaluated, I want it to MsgBox a value of 1. If it becomes zero upon evaluating the second condition, return a 2 instead. If it doesn't hit zero until adding the third condition, I want it to return a 3 instead, and so on.
For the sake of simplicity, assume it only has to work for one cell, rather than looping through each cell in my column.
EDIT: Here is the code I've written so far. It will take a COUNTIFS() formula and run the first condition as a COUNTIF(), but I haven't been able to think of how to extend this to also do the later conditions.
'Find Indexes
countifsStart = InStr(1, cell.Formula, "COUNTIFS(")
sheetNameStart = InStr(countifsStart, cell.Formula, "(") + 2
sheetNameEnd = InStr(sheetNameStart, cell.Formula, "'")
searchRangeStart = InStr(sheetNameEnd, cell.Formula, "!") + 1
searchRangeSemicolon = InStr(searchRangeStart, cell.Formula, ":")
searchStringStart = InStr(searchRangeSemicolon, cell.Formula, ",") + 2
searchStringEnd = InStr(searchStringStart, cell.Formula, ",") - 1
'Parse formula components
sheetName = Mid(cell.Formula, sheetNameStart, sheetNameEnd - sheetNameStart)
searchColumn = Mid(cell.Formula, searchRangeStart, 1)
Set searchRange = Range(searchColumn & ":" & searchColumn)
searchString = Mid(cell.Formula, searchStringStart, searchStringEnd - searchStringStart)
'Run the countif
countIf = Application.WorksheetFunction.countIf(Sheets(sheetName).Range(searchColumn & ":" & searchColumn), searchString)
'Point out the culprit
MsgBox "Sheet Name: " & sheetName & vbNewLine & _
"Search Range: " & searchColumn & ":" & searchColumn & vbNewLine & _
"Search String: " & searchString & vbNewLine & _
"CountIf: " & countIf
Perhaps something like this will work for you:
Sub tgr()
Dim rFormula As Range
Dim hArguments As Object
Dim sArguments As String
Dim sMessage As String
Dim sTemp As String
Dim sChar As String
Dim lFunctionStart As Long
Dim lParensPairs As Long
Dim lQuotePairs As Long
Dim bArgumentEnd As Boolean
Dim i As Long, j As Long
Set hArguments = CreateObject("Scripting.Dictionary")
For Each rFormula In Selection.Cells
lFunctionStart = InStr(1, rFormula.Formula, "COUNTIFS(", vbTextCompare)
If lFunctionStart > 0 Then
lFunctionStart = lFunctionStart + 9
lParensPairs = 1
lQuotePairs = 0
j = 0
bArgumentEnd = False
For i = lFunctionStart To Len(rFormula.Formula)
sChar = Mid(rFormula.Formula, i, 1)
Select Case sChar
Case "'", """"
If lQuotePairs = 0 Then
lQuotePairs = lQuotePairs + 1
Else
lQuotePairs = lQuotePairs - 1
End If
sTemp = sTemp & sChar
Case "("
If lQuotePairs = 0 Then
lParensPairs = lParensPairs + 1
End If
sTemp = sTemp & sChar
Case ")"
If lQuotePairs = 0 Then
lParensPairs = lParensPairs - 1
If lParensPairs = 0 Then
j = j + 1
hArguments(j) = sTemp
sTemp = vbNullString
Exit For
Else
sTemp = sTemp & sChar
End If
Else
sTemp = sTemp & sChar
End If
Case ","
If lQuotePairs = 0 And lParensPairs = 1 Then
bArgumentEnd = True
j = j + 1
hArguments(j) = sTemp
sTemp = vbNullString
Else
sTemp = sTemp & sChar
End If
Case Else
sTemp = sTemp & sChar
End Select
Next i
For i = 1 To hArguments.Count Step 2
If Len(sArguments) = 0 Then
sArguments = hArguments(i) & "," & hArguments(i + 1)
Else
sArguments = sArguments & "," & hArguments(i) & "," & hArguments(i + 1)
End If
If Evaluate("COUNTIFS(" & sArguments & ")") = 0 Then
MsgBox "Search Range: " & hArguments(i) & Chr(10) & _
"Search String: " & hArguments(i + 1) & Chr(10) & _
"Countif condition position: " & Int(i / 2) + 1
Exit For
End If
Next i
End If
Next rFormula
End Sub
Posting just as an alternative method to get at the arguments (which I found in another answer elsewhere by Peter Thornton)
Private args()
Sub Tester()
Debug.Print GetZeroStep(Range("M1"))
End Sub
Function GetZeroStep(c As Range)
Dim f, arr, i, r, s, n, rng, v
f = Replace(c.Formula, "=COUNTIFS(", "=MyUDFTmp(")
Debug.Print f
r = Application.Evaluate(f)
For i = 0 To UBound(args) Step 2
n = n + 1
Set rng = args(i)
v = args(i + 1)
If Not IsNumeric(v) Then v = """" & v & """"
s = s & IIf(s <> "", ",", "") & "'" & rng.Parent.Name & "'!" & _
rng.Address() & "," & v
Debug.Print "=COUNTIFS(" & s & ")"
r = Application.Evaluate("=COUNTIFS(" & s & ")")
If r = 0 Then
GetZeroStep = n
Exit Function
End If
Next i
GetZeroStep = 0 '<< didn't return zero on any step...
End Function
'https://social.msdn.microsoft.com/Forums/Lync/en-US/8c52aee1-5168-4909-9c6a-9ea790c2baca/get-formula-arguments-in-vba?forum=exceldev
Public Function MyUDFTmp(ParamArray arr())
args() = arr
End Function

Show in MSgBox all nonempty values from row

I am working on an Excel sheet of row size A:ZZ and there should only be 7 cells with values. I am trying to make a kind of "filter" that will check the number of non empty cells and in case when there will be more than 7 nonempty cells will print a message in MsgBox (and till this point is working). But in the MsgBox I would like to se also just those values from the row (separated eg. with coma) - this is although not working due to some problem with Intersect syntax. Here is the code
Sub blanks()
Dim a, b As Integer
a = 0
Range("A1").Select
Do
With ActiveSheet.Range(Rows(b))
b = ActiveCell.Row
a = Application.WorksheetFunction.CountA(ActiveSheet.Rows(b))
If a > 7 Then
MsgBox ("ERROR" & "/n" & Application.Intersect(.SpecialCells(xlCellTypeVisible)))
Exit Do
Else
ActiveCell.Offset(1, 0).Select
End If
End With
Loop Until ActiveCell = "stop"
End Sub
What is there wrong?
This will give you the constant values (i.e. not from a formula):
Sub ShowValues()
Dim rowNum As Long
Dim rowRange As Range
Dim valRange As Range
Dim msg As String
rowNum = 1
With ThisWorkbook.Worksheets("Sheet1")
Do While .Cells(rowNum, 1) <> "stop"
Set rowRange = .Cells(rowNum, 1).Resize(1, 702)
If Application.WorksheetFunction.CountA(rowRange) > 7 Then
'Add row number to message.
msg = msg & "Row: " & rowRange.Row & ": "
'Add values to message separated by comman.
For Each valRange In rowRange.SpecialCells(xlCellTypeConstants)
msg = msg & valRange.Value & ", "
Next valRange
'Remove last comma.
msg = Left(msg, Len(msg) - 2)
'Line break.
msg = msg & vbCr
End If
rowNum = rowNum + 1
Loop
End With
MsgBox msg, vbOKOnly + vbInformation
End Sub
or this will give you the addresses:
Sub ShowAddressOfValues()
Dim rowNum As Long
Dim rowRange As Range
Dim msg As String
rowNum = 1
With ThisWorkbook.Worksheets("Sheet1")
Do While .Cells(rowNum, 1) <> "stop"
Set rowRange = .Cells(rowNum, 1).Resize(1, 702)
If Application.WorksheetFunction.CountA(rowRange) > 7 Then
msg = msg & "Row: " & rowRange.Row & ". Address: " & _
rowRange.SpecialCells(xlCellTypeConstants).Address & vbCr
End If
rowNum = rowNum + 1
Loop
End With
MsgBox msg, vbOKOnly + vbInformation
End Sub

Choose random number from an Excel range

In the list bellow it's an Excel Range, I need to choose two numbers equals to 100 so in return I want to get (30 & 70) or (60 & 40). Can I do that dynamically
I use Excel but if you have any suggestion of other programs it would be fine.
A
30
60
70
40
here the code without verification of duplicated pairs
Sub test()
Dim x&, lastR&, oCell1 As Range, oCell2 As Range, Key As Variant
Dim Dic As Object: Set Dic = CreateObject("Scripting.Dictionary")
x = 1
lastR = ActiveSheet.Cells(Rows.Count, 1).End(xlUp).Row
For Each oCell1 In ActiveSheet.Range("A1:A" & lastR)
For Each oCell2 In ActiveSheet.Range("A1:A" & lastR)
If oCell1.Value + oCell2.Value = 100 Then
Dic.Add x, "(" & oCell1.Value & " & " & oCell2.Value & ")"
x = x + 1
End If
Next
Next
For Each Key In Dic
Debug.Print Key, Dic(Key) 'output in immediate window all possible
Next
MsgBox Dic(WorksheetFunction.RandBetween(1, Dic.Count))
End Sub
here the result
here the code with verification of duplicated pairs
Sub test()
Dim x&, S$, S2$, check%, lastR&, oCell1 As Range, oCell2 As Range, Key As Variant
Dim Dic As Object: Set Dic = CreateObject("Scripting.Dictionary")
x = 1
lastR = ActiveSheet.Cells(Rows.Count, 1).End(xlUp).Row
For Each oCell1 In ActiveSheet.Range("A1:A" & lastR)
For Each oCell2 In ActiveSheet.Range("A1:A" & lastR)
check = 0
If oCell1.Value + oCell2.Value = 100 Then
S = "(" & oCell1.Value & " & " & oCell2.Value & ")"
S2 = "(" & oCell2.Value & " & " & oCell1.Value & ")"
For Each Key In Dic
If Dic(Key) = S Or Dic(Key) = S2 Then
check = 1: Exit For
End If
Next
If check = 0 Then
Dic.Add x, S
Debug.Print x, Dic(x)
x = x + 1
End If
End If
Next
Next
MsgBox Dic(WorksheetFunction.RandBetween(1, Dic.Count))
End Sub
here the result
With your data in A1 thru A4, try this macro:
Sub JustKeepTrying()
Dim N As Long, M As Long, wf As WorksheetFunction
Set wf = Application.WorksheetFunction
Do
N = wf.RandBetween(1, 4)
M = wf.RandBetween(1, 4)
If N <> M Then
If Cells(M, 1) + Cells(N, 1) = 100 Then
MsgBox Cells(M, 1).Address & vbTab & Cells(M, 1).Value & vbCrLf _
& Cells(N, 1).Address & vbTab & Cells(N, 1).Value
Exit Sub
End If
End If
Loop
End Sub
Assuming you have in range A1:a11 numbers from 0 to 100 step by 10 [0,10,20,...,90,100] you could use this logic (here, result is highlighted with blue color)
Set BaseRange = Range("A1:a11")
BaseRange.ClearFormats
'first number- rundomly find
With BaseRange.Cells(Int(Rnd() * BaseRange.Cells.Count) + 1)
.Interior.Color = vbBlue
FirstNo = .Value
End With
'second number find by difference- error handling required if there is no matching value for each number
BaseRange.Find(100 - FirstNo).Interior.Color = vbBlue

Resources