I write a VBA CODE that's filter a column and return the result in msgbox. The problem is: the msgbox does not show me all the values because the column contains more than 100 values.
My question is: how can I modify the form of the msgbox and separate it with comma.
Many thanks
Sub Fstr()
Dim str As String
Dim j As Integer
j = 2
For i = 1 To ActiveSheet.UsedRange.Count
If Cells(i, 6) = "CEM" Then
str = str & CStr(Cells(i, 2)) & vbCrLf
'ThisWorkbook.Sheets("BDD").Range("B" & j) = Cells(i, 4)
j = j + 1
End If
Next i
MsgBox str
End Sub
To add a user form and show the str:
Go to VBA Editor window
Insert a UserForm
Add a TextBox from Controls
Right click the textbox and click properties
from the properties change the Multiline = True
You can show the form using the below code
In Module1:
Sub Fstr()
Dim str As String
Dim j As Integer
j = 2
For i = 1 To ActiveSheet.UsedRange.Count
If Cells(i, 6) = "CEM" Then
str = str & CStr(Cells(i, 2)) & vbCrLf
'ThisWorkbook.Sheets("BDD").Range("B" & j) = Cells(i, 4)
j = j + 1
End If
Next i
'MsgBox str
UserForm1.TextBox1.Text = str
UserForm1.Show
End Sub
Related
I'd like to concatenate the number of days that add up to 80%. Please see the example below;
I can run a code that concatenates Range A1:A7 and the result is printed in C1;
Sub Concatenator()
Dim lastLng As Long
Dim result As String
Dim delim As String
Dim b As String
delim = "&"
lastLng = Worksheets("Sheet1").Range("A1048576").End(xlUp).Row
For i = 1 To lastLng
b = Cells(i, 1).Value
result = result & b & delim
Next
result = Left(result, Len(result) - Len(delim))
Worksheets("Sheet1").Cells(1, 3).Value = result
End Sub
I'd to add a "Do Until" loop that loops until the value in column is greater than 80%. I've tried to amend the code above with the "Do Until" loop;
Sub Concatenator()
Dim lastLng As Long
Dim result As String
Dim delim As String
Dim b As String
delim = "&"
lastLng = Worksheets("Sheet1").Range("A1048576").End(xlUp).Row
Do Until Cells(i, 2).Value = ">80%"
For i = 1 To lastLng1
b = Cells(i, 1).Value
result = result & b & delim
Next
Loop
result = Left(result, Len(result) - Len(delim))
Worksheets("Sheet1").Cells(1, 3).Value = result
End Sub
As far as I understand this might work for you
To understand how to set up the code, take a look For-Loop and Do-while, then combine the conditions with the loop as the following code
i = 1
Do Until Cells(i, 2).Value = 0.8 'Loop until request condition
If i > lastLng1 Then Exit Do 'Loop until end of the range
b = Cells(i, 1).Value
result = result & b & delim
i = i + 1
Loop
'Or------------------------------
For i = 1 To lastLng1 'Loop until end of the range
If Cells(i, 2).Value = 0.8 Then Exit For 'Loop until request condition
b = Cells(i, 1).Value
result = result & b & delim
Next
This is what worked for me
Sub Concatenator()
Dim lastLng As Long
Dim result As String
Dim delim As String
Dim b As String
delim = "&"
lastLng = Worksheets("Sheet1").Range("A1048576").End(xlUp).Row
For i = 1 To lastLng
If Cells(i, 2).Value > "80" Then Exit For
b = Cells(i, 1).Value
result = result & b & delim
Next
result = Left(result, Len(result) - Len(delim))
Worksheets("Sheet1").Cells(1, 3).Value = result
End Sub
I changed the value in column be from a percentage to a number. I also removed the equal sign
For i = 1 To lastLng
If Cells(i, 2).Value > "80" Then Exit For
b = Cells(i, 1).Value
result = result & b & delim
Next
This will work very well for me for now. Thank you #The GridLock
I am trying to copy named range in excel from one sheet to another, this works superb when I am using a static name. However now I would like to get the named range from a userform list box, and I am unsure how to do this. My copy function takes in the row number and I need to find this row number based on the string coming from the Listbox. If the listbox says Bolts the named range would be _OutputBolts which is refered to A123.
Call copyRows(ws, ThisWorkbook.Sheets("Templates").[_DrawingInputs].Row)
Call copyRows(ws, ThisWorkbook.Sheets("Templates").[_GeneralInputs].Row)
Call copyRows(ws, ThisWorkbook.Sheets("Templates").[_MaterialData].Row)
If GUI.ListBox_AdditionalComponents.ListCount > 0 Then
For i = 0 To GUI.ListBox_AdditionalComponents.ListCount - 1
namedRange = "[_Output" & GUI.ListBox_AdditionalComponents.List(i) & "]"
Call copyRows(ws, ThisWorkbook.Sheets("Templates").namedRange.Row)
Next i
End If
The copy procedure
Public Sub copyRows(ByRef shNew As Worksheet, startRow As Integer)
Dim i, j As Integer
Dim wsTemplates As Worksheet
Dim temp As Variant
Dim rowOverview As Integer
Dim lastCol As Integer
On Error Resume Next
Set wsTemplates = ThisWorkbook.Sheets("Templates")
i = startRow ' Where to copy from in templates
j = getLastRow(shNew, 1) 'Where to copy to, i.e append
If j > 2 Then
j = j + 2
End If
Do While wsTemplates.Cells(i, 1) <> ""
'copy the old range
wsTemplates.Rows(i).EntireRow.Copy
'paste it
shNew.Rows(j).EntireRow.Select
shNew.Paste
'format height
temp = wsTemplates.Rows(i).Height
shNew.Rows(j).RowHeight = CInt(temp)
' fill in the value from the GUI
temp = ""
temp = GUI.Controls("TextBox_" & Replace(shNew.Cells(j, 1).value, " ", "")).value
If temp = "" Then
temp = GUI.Controls("ComboBox_" & Replace(shNew.Cells(j, 1).value, " ", "")).value
End If
If temp <> "" Then
shNew.Cells(j, 4).value = temp
End If
'hyperlink drawing
If shNew.Cells(j, 1).value = "Drawing Name" Then
Call createHyperLink(shNew, j, 4, shNew.Cells(j, 4).value, GetFileNameWithOutExtension(getFilenameFromPath(shNew.Cells(j, 4).value)), shNew.Cells(j, 4).value)
End If
'update counters
i = i + 1
j = j + 1
Loop
' Format column widths, seems to be bug in this one...Maybe move out due to the fact we could do this once..
lastCol = getLastColumn(wsTemplates, 1)
For i = 1 To lastCol
temp = wsTemplates.Cells(1, i).Width
shNew.Columns(i).ColumnWidth = temp
Next i
End Sub
Solved by using Range(address), see comment
We have the column "following ID", which contains IDs of predecessors in the format "1; 2; 3; 4". Now I want to find the ID inside a specific cell. My problem is, that if I f.e. searching for "1", it also is true when there is a "11, 21, 13, 14, ..." inside the cell. Is there a way to search for the "ID" in "following ID", without getting true when the ID is part of an other ID?
For i = 2 To 250
Dim tmp As String
tmp = ""
If Cells(i, 1) = "" Then Exit For
For j = 2 To 250
If Cells(j, 1) = "" Then
Exit For
End If
If Cells(j, 11) = Cells(i, 1) Then
If tmp = "" Then
tmp = Cells(j, 1)
Else
tmp = tmp & "; " & Cells(j, 1)
End If
End If
Next j
Cells(i, 10) = tmp
Next i
Picture of Data
What you try to do can be described minimally with the following:
- Try to search for "1" in the string "1;2;3;4;11;12;13", returning only "1" and not "11", "12", "13".
This is a way to do it:
split the string to array by ";"
search in the array
The code would look like this:
Option Explicit
Public Sub TestMe()
Dim inputA As String
Dim cnt As Long
Dim arr As Variant
inputA = "1;2;3;4;11;12;13"
arr = Split(inputA, ";")
For cnt = LBound(arr) To UBound(arr)
If 1 = arr(cnt) Then
Debug.Print "Found in position " & cnt
Exit For
End If
Next cnt
End Sub
You can create a UDF like below:
Public Function FindID(rngToCheck As Range, strVal As String) As Boolean
If InStr(1, ";" & Replace(rngToCheck.Value, " ", "") & ";", ";" & strVal & ";", vbTextCompare) > 0 Then FindID = True
End Function
And then check the cell like below assuming your data is in Cell A2:
=FindID(A2,"1")
I have some code I'm working on where I need to detect if a cell has a particular word in it, and if it does, it inserts a particular string in the adjacent cell. However, I'm having issues doing the detection part of it! Here's what I have so far.
Sub searchandpaste()
Dim stopvar As Variant
Dim i As Variant
Dim j As Variant
Dim k As Variant
Dim TestVal1 As Variant
Dim TestVal2 As Variant
i = 0
j = 0
Do While stopvar = 0
i = i + 1
MsgBox ("Row " & i)
MsgBox ("j equals " & j)
'If the first cell is empty, that means we've hit the end of the worksheet, and it stops the do-while loop
TestVal1 = Cells(i, 1)
If TestVal1 = 0 Then
stopvar = 1
Else
TestVal2 = Cells(i, 6)
If IsEmpty(TestVal2) = True Then
MsgBox ("Detected Empty Cell in Column 6")
j = 1
ElseIf TestVal2 = "XXXX" Then
'This means we have a place we need to insert a value
MsgBox ("Detected XXXX in Column 6")
'We know at this point that in Cells(6,i) we have a value we need to insert. Thus, we need to search Cells(7,i) for key text
If IsNumeric(Cells(7, j).Find("CYLINDER")) Or IsNumeric(Cells(7, j).Find("CYLINDERS")) Or IsNumeric(Cells(7, j).Find("CYL")) = True Then
MsgBox ("Detected the string CYLINDER")
j = j + 1
MsgBox ("j equals " & j)
Else
MsgBox ("Did not detect the string CYLINDER")
End If
End If
End If
Loop
End Sub
I'll cut out the important part, here.
'We know at this point that in Cells(6,i) we have a value we need to insert. Thus, we need to search Cells(7,i) for key text
If IsNumeric(Cells(7, j).Find("CYLINDER")) Or IsNumeric(Cells(7, j).Find("CYLINDERS")) Or IsNumeric(Cells(7, j).Find("CYL")) = True Then
MsgBox ("Detected the string CYLINDER")
j = j + 1
MsgBox ("j equals " & j)
Else
MsgBox ("Did not detect the string CYLINDER")
End If
My intention is that this would search the string in cell (i,7) for different variations of the word Cylinder, and if it finds one, it'll return TRUE or FALSE (false would be a NAN, which is caught by the IsNumeric and turned to a FALSE), and let me know it detected it. However, this doesn't seem to be working.
Can anybody pinpoint my error?
Is there a better way to search the string? Like, could I just search for "CYL" and have it say it detected any of those variations?
You should use the InStr function to do the comparison like this:
If InStr(1, Cells(7, j), "CYLINDER") > 0 Or _
InStr(1, Cells(7, j), "CYLINDERS") > 0 Or _
InStr(1, Cells(7, j), "CYL") > 0 Then
MsgBox ("Detected the string CYLINDER")
j = j + 1
MsgBox ("j equals " & j)
Else
MsgBox ("Did not detect the string CYLINDER")
End If
For more information on this function visit MSDN at https://msdn.microsoft.com/en-us/library/office/gg264811%28v=office.15%29.aspx
To avoid different cases (as suggested by #Sgdva) you have several options:
If InStr(1, Cells(7, j), "CYLINDER", vbTextCompare) > 0 Or _
InStr(1, Cells(7, j), "CYLINDERS", vbTextCompare) > 0 Or _
InStr(1, Cells(7, j), "CYL", vbTextCompare) > 0 Then
MsgBox ("Detected the string CYLINDER")
j = j + 1
MsgBox ("j equals " & j)
Else
MsgBox ("Did not detect the string CYLINDER")
End If
OR
If InStr(1, UCase(Cells(7, j)), "CYLINDER") > 0 Or _
InStr(1, UCase(Cells(7, j)), "CYLINDERS") > 0 Or _
InStr(1, UCase(Cells(7, j)), "CYL") > 0 Then
MsgBox ("Detected the string CYLINDER")
j = j + 1
MsgBox ("j equals " & j)
Else
MsgBox ("Did not detect the string CYLINDER")
End If
OR
Use the Option Compare Text at the top of your module and as pointed out here:
https://msdn.microsoft.com/en-us/library/office/gg278697.aspx
At the same time, you might want to consider inserting the line:
Option Explicit
(for good coding practice).
Not sure what you are trying to accomplish with the j variable as it doesn't seem to have any relevance. Except I seem to have identified an error in your code and the answer provided by Ralph. Cells(7, j) should rather be Cells(i, 7). Full code would be:
Sub searchandpaste()
Dim stopvar As Variant
Dim i As Variant
Dim j As Variant
Dim k As Variant
Dim TestVal1 As Variant
Dim TestVal2 As Variant
i = 0
j = 0
Do While stopvar = 0
i = i + 1
MsgBox ("Row " & i)
MsgBox ("j equals " & j)
'If the first cell is empty, that means we've hit the end of the worksheet, and it stops the do-while loop
TestVal1 = Cells(i, 1)
If TestVal1 = 0 Then
stopvar = 1
Else
TestVal2 = Cells(i, 6)
If IsEmpty(TestVal2) = True Then
MsgBox ("Detected Empty Cell in Column 6")
j = 1
ElseIf TestVal2 = "XXXX" Then
'This means we have a place we need to insert a value
MsgBox ("Detected XXXX in Column 6")
'We know at this point that in Cells(6,i) we have a value we need to insert. Thus, we need to search Cells(7,i) for key text
If InStr(LCase(Cells(i, 7)), "cyl") > 0 Then
MsgBox ("Detected the string CYLINDER")
j = j + 1
MsgBox ("j equals " & j)
Else
MsgBox ("Did not detect the string CYLINDER")
End If
End If
End If
Loop
End Sub
I am trying to build a user defined function using VBA for excel. That would concatenate a list of stores which has a x mark in that row.
Store1 Store2 Store3 Concatenate
x x Store1,Store3
x x tore1,Store2
x Store1
I managed to write this vba code, but I am not sure this is the best approach. As I was tesing in on 1000 and more lines, it was quite slow. Maybe it is possible to optimise it?
firstStore you point where the first store starts (not the names, but the x marks,lastStore1 the last column. listofstores1 is the row where the store names are.
Function listofstores(firstStore As Range, lastStore1 As Range, listofstores1 As Range)
Application.Volatile
Dim offsetvalue As Integer
offsetvalue = -(lastStore1.Row - listofstores1.Row)
lastStore = lastStore1.Column
Set initial = firstStore
For i = 1 To lastStore
If initial = "X" Or initial = "x" Then Store = initial.Offset(offsetvalue, 0)
c = 1
Set initial = initial.Offset(0, c)
listofstores = listofstores & " " & Store
Store = ""
Next i
End Function
Short but intricate.
uses Evaluate to return an array of matches (Store numbers v x)
Filter removes the non-matches ("V")
Join to make the string from the final array of matches
UDF
Function Getx(Rng1 As Range, Rng2 As Range) As String
Getx = Join(Filter(Evaluate("=ÏF(" & Rng2.Address & "=""x""," & Rng1.Address & ",""V"")"), "V", False), ",")
End Function
Another way to achieve is as below. You can do any where in sheets
Sub Main()
Call getlistofstores(Range("G13:L15"), Range("G12:L12"))
End Sub
Function getlistofstores(stores As Range, listofstores As Range)
Application.Volatile
Dim fullconcatstring As String
Dim row As Integer
Dim column As Integer
a = stores.Count / listofstores.Count
b = listofstores.Count
row = stores.Cells(1).row
column = stores.Cells(1).column + (b)
For i = 1 To a
For j = 1 To b
If stores.Cells(i, j) = "x" Then
If concatstring <> "" Then
concatstring = concatstring & ", " & listofstores.Cells(j)
Else
concatstring = listofstores.Cells(j)
End If
End If
Next j
fullconcatstring = fullconcatstring & Chr(10) & Chr(11) & concatstring
concatstring = ""
Next i
Call concatenateallstores(row, column, fullconcatstring)
End Function
Sub concatenateallstores(r As Integer, c As Integer, d As String)
str1 = Split(d, Chr(10) & Chr(11))
str2 = UBound(str1)
For i = 1 To str2
Cells(r, c) = str1(i)
r = r + 1
Next i
End Sub