I am trying to get the items that I have and initiate all the separate items into its own respective cell.
With Me.selecteditems
For i = 1 To .ListCount - 1
If .Selected(i) Then
found = True
On Error Resume Next
str = ThisWorkbook.Sheets(9).Range("A1:Cells(i, 1)")
quantity = ThisWorkbook.Sheets(9).Range("A1:Cells(i, 2)")
On Error GoTo 0
End If
Next i
End With
This part of the below code, is supposed to put the items that come from the longer part of the code and put in the item, str, and the amount, quantity. I tried different ways and just recently I tried repeating how it was before, it doesn't come out that well. Also without the error it throws me:
Application-defined or Object-defined Error
The Whole Code:
Dim i As Long, j As Long, ii As Long
Dim found As Boolean
Dim str As String
Dim message, title, defaultval As String
Dim quantity As String
With Me.selecteditems
For i = 0 To .ListCount - 1
If .Selected(i) Then
found = True
For ii = 0 To .ColumnCount - 1
If str = "" Then
str = .List(i, ii) & vbTab
Else
If ii < .ColumnCount - 1 Then
str = str & .List(i, ii) & vbTab
Else
str = str & .List(i, ii)
End If
End If
Next ii
message = "How much" & vbCrLf & str & "?"
title = "Amount"
defaultval = "1"
quantity = InputBox(message, title, defaultval)
str = str & " x " & quantity & vbNewLine
End If
Next i
End With
With Me.selecteditems
For i = 1 To .ListCount - 1
If .Selected(i) Then
found = True
On Error Resume Next
str = ThisWorkbook.Sheets(9).Range("A1:Cells(i, 1)")
quantity = ThisWorkbook.Sheets(9).Range("A1:Cells(i, 2)")
On Error GoTo 0
End If
Next i
End With
Related
I am trying to get a specific cell value in brackets and check if this value is in other sheet. This is the column with the possible values:
StrS Format
HEADER
NOBREAK
IGNORE
REPEATABLE …-n can be up to 100
I want to split the string in the cell, check if its value is one of the above, if it is equal with "REPEATABLE" extract the following block specifications: . If is not defined in “BY Variables” show error. This is a similar issue with this one:
VBA-Count and collect every found match in regular expression -again have to get values with brackets
Here is my code:
Public Function IsItGood(aWord As Variant) As Boolean
Dim s As String
s = "|" '-means or
'tmp = s & aWord & s
tmp = Replace(s & aWord & s, ",", "")
patern = ""
patern = patern & "HEADER|NOBREAK|REPEATABLE" & s
If InStr(1, patern, tmp) > 0 Then
IsItGood = True
Else
IsItGood = False
End If
End Function
Function check_cell_values()
On Error Resume Next
Application.EnableEvents = False
Dim msg As String
msg = ""
Dim arr As Variant
Dim a As Variant
arr = Split(Target, " ")
For Each a In arr
If Target.Column = 10 And (Target.Row > 2 And Target.Row <= 308) Then
If IsItGood(a) Then
msg = msg & vbCrLf & (" In cell" + Target.Address(0, 0)) & vbCrLf & a & vbCrLf + "is ok"
Else
msg = msg & vbCrLf & (" In cell" + Target.Address(0, 0)) & vbCrLf & a & vbCrLf + "is invalid value"
Application.Undo
End If
End If
Next a
If msg <> "" Then MsgBox msg
check_cell_values = msg
End Function
Sub by_blocks_check()
Application.EnableEvents = False
Dim func1
func1 = check_cell_values()
End Sub
I think instead of a regular expression it is better to use an array from the possible values but I don`t know how to get the value after "Repeatable".
Example output:
This code is a part of bigger code that takes words from a listbox and places into another listbox, which with this code separates the words in the listbox and establishes into words that are able to be inserted into a cell, for some reason second strsplt is not showing, everything else is working very well, it's just this one, I need help with and there is no error that is thrown out. I've looked it over with F8 and breakpoints and the problem seems to be with
If ii < .ColumnCount - 1 Then
str = str & .List(i, ii) & vbCrLf
Else
str = str & .List(i, ii)
End If
The Whole Code:
With Me.selecteditems
ThisWorkbook.Sheets(9).Range("A:B").ClearContents
For i = 0 To .ListCount - 1
If .Selected(i) Then
found = True
For ii = 0 To .ColumnCount - 1
ReDim strsplt(0 To i)
If str = "" Then
str = .List(i, ii) & vbCrLf
Else
If ii < .ColumnCount - 1 Then
str = str & .List(i, ii) & vbCrLf
Else
str = str & .List(i, ii)
End If
End If
Next ii
message = "How much" & vbCrLf & str & "?" & vbCrLf
title = "Amount"
defaultval = "1"
quantity = InputBox(message, title, defaultval)
strsplt = Split(str, "*")
End If
'On Error Resume Next
With ThisWorkbook.Sheets(9)
.Range("A" & (i + 1)).Value = strsplt(i)
.Range("B" & (i + 1)).Value = quantity
End With
'On Error GoTo 0
Next i
End With
EDIT: The way it looks like using debug.print str
item1
item2 item3 item4 ...
Try a bit brute forcing like this:
If ii < .ColumnCount - 1 Then
str = str & .List(i+1, ii) & vbCrLf
Else
str = str & .List(i+1, ii)
End If
I have changed i to i+1 in your code.
Then debug again. If it does not work, try i-1, ii+1, ii-1. One of these will work and it may give an out of range error. Then fix the array length and have fun.
I'm a graphic artist, new to Excel and VBA but trying to use it to process mountains of data in excel to be used as variable data in Illustrator.
If I want to convert cells with product names for signs like "Budwieser, Bud Light & Bud Black Crown" to an abbreviation following the format "Budweiser_BL_BBC"
I have written a function that I thought would accomplish my task but it returns #VALUE!
Edit
To explain the logic: my idea was to take the string, split it on " & " and then split the first position of the resulting array on ", " then adding what was after the "&" to the end of the second array - this array, sProd, has the products separated into different positions of the array.
Then looping through that array and splitting each product at the spaces creating a jagged array.
Then loop through that array again creating a string taking only the first letter of each word in each product, separating products with an underscore. The exception being that the first word of the first product is spelled out and set in proper case. (Just saw an error in my logic and added the code for the first word exception).
Edit #2
The function should return a string with the first word of the original string set in proper case with all other words abbreviated to their first letter and products separated by underscores. So "Budweiser, Bud Light & Bud Light Lime" returns "Budweiser_BL_BLL", "All Coke & Dr Pepper Products" would return "AllC_DPP" and "Gatorade" returns "Gatorade".
This is my first bout with Excel and VBA.
Function Abbrev(p As String) As String
Dim sAmpersand() As Variant
Dim sProd() As Variant
sAmpersand = Split(p, " & ")
sProd = Split(sAmpersand(0), ", ")
sProd(UBound(sProd)) = sAmpersand(1)
Dim ProductCount As Integer
Dim ProductEnd As Integer
ProductEnd = UBound(sProd) - 1
For ProductCount = 0 To ProductEnd
sProd(ProductCount) = Split(sProd(ProductCount), " ")
ProductCount = ProductCount + 1
Next ProductCount
Dim WordCount As Integer
Dim WordEnd As Integer
WordEnd = UBound(sProd(ProductCount)) - 1
Abbrev = StrConv(sProd(0)(0), vbProperCase)
For ProductCount = 0 To ProductEnd
For WordCount = 0 To WordEnd
If ProductCount = 0 Then
WordCount = 1
End If
Abbrev = Abbrev & Left(sProd(ProductCount)(WordCount), 1)
WordCount = WordCount + 1
Next WordCount
If ProductCount + 1 < ProductEnd Then
Abbrev = Abbrev & "_"
End If
ProductCount = ProductCount + 1
Next ProductCount
End Function
Working code:
Function Abbrev(p As String) As String
Dim res As String, w1, w2
res = Split(Split(p, ",")(0), " ")(0)
If res = Split(p, ",")(0) Then res = res & "_"
For Each w1 In Split(Mid(Replace(p, " &", ","), Len(res) + 1), ",")
For Each w2 In Split(w1, " ")
res = res & Left(w2, 1)
Next w2
res = res & "_"
Next w1
Abbrev = IIf(Right(res, 1) <> "_", res, Left(res, Len(res) - 1))
End Function
Here's a better abbreviate function:
Function Abbreviate(Name As String) As String
Dim I As Integer
Dim sResult As String
Dim sTemp As String
I = InStr(Name, " ")
If I < 1 Then
Abbreviate = Name
Exit Function
End If
sResult = Left$(Name, I)
sTemp = Name
Do While I > 0
sTemp = Right$(sTemp, Len(sTemp) - I)
If Left$(sTemp, 1) = "(" Then
If Mid$(sTemp & "***", 3, 1) = ")" Then
sResult = sResult & " " & Left$(sTemp, 3)
Else
sResult = sResult & " " & Left$(sTemp, 1)
End If
Else
sResult = sResult & " " & Left(sTemp, 1)
End If
I = InStr(sTemp, " ")
Loop
Abbreviate = sResult
End Function
This is from user al_b_cnu on mrexcel.com
Here is a modified version to shorten up the result a bit:
Function Abbreviate(Name As String) As String
Dim I As Integer
Dim sResult As String
Dim sTemp As String
I = InStr(Name, " ")
If I < 1 Then
Abbreviate = Name
Exit Function
End If
sResult = Left$(Name, I)
sTemp = Name
Do While I > 0
sTemp = Right$(sTemp, Len(sTemp) - I)
If Left$(sTemp, 1) = "(" Then
If Mid$(sTemp & "***", 3, 1) = ")" Then
sResult = sResult & Left$(sTemp, 3)
Else
sResult = sResult & Left$(sTemp, 1)
End If
Else
sResult = sResult & Left(sTemp, 1)
End If
I = InStr(sTemp, " ")
Loop
Abbreviate = sResult
End Function
I've been struggling with this for a day now.
I have a list box that is populated with x items. Could be 1 - x
I need to take all the items in the list box and format them into a string
which I submit into an oracle database. I'm using INLIST on the SQL side and because of that I can only have a maximum of 100 items in my string.
So for example if I was to have 547 items in the listbox, I would iterate through all 547 items, but at every 100 I would submit into the database, returning my result into my collection class, finishing with the last 47.
here's what i have so far. There is some attempts to solve my problem in the code so if it's confusing i'll try to explain.
Public Function SearchBMS()
On Error GoTo HandleError
Dim rst As ADODB.Recordset
Dim sESN As String
Dim i As Integer
Dim x As Integer
Dim maxrec As Integer
Dim itemcnt As Integer
Dim iBlockCount As Integer
With frmEngineCampaignSearch.lstbxESNNumbers
itemcnt = .ListCount - 2
'iBlockCount = GetBlockCount(itemcnt)
x = 0
maxrec = 100
Debug.Assert itemcnt = 200
For i = 0 To itemcnt
For x = i To maxrec
MsgBox "test", vbOKOnly
i = i + 100
Next x
If i = itemcnt Then ' if I = last item than we put the closing parenthesis on our string
sESN = sESN & "'" & .list(i) & "'"
Else
sESN = sESN & "'" & .list(i) & "' , " ' otherwise there are more items so we seperate by comma
End If
If itemcnt <= 100 Then
Set rst = Nothing
'Set rst = rstGetCustomerInfo(sESN)
'LoadRSTToCollection rst
elseif
While x = maxrec
MsgBox "submit first 100", vbOKOnly
'Set rst = Nothing
'Set rst = rstGetCustomerInfo(sESN)
'LoadRSTToCollection rst
sESN = gC_sEMPTY_STRING
maxrec = maxrec + 100
Wend
x = x + 1
Next i
End With
HandleError:
If Err.Number > 0 Then
MsgBox Err.Number & ": " & Err.Description
End If
This function is to get the number of times I would have to perform the submission but i hit a road block on how to use it within the for loop
Public Function GetBlockCount(ByRef lItemCnt As Long) As Integer
Dim x As Double
If lItemCnt <= 100 Then
GetBlockCount = 1
Exit Function
ElseIf lItemCnt > 100 Then
x = Round(lItemCnt / 100)
If lItemCnt Mod 100 > 0 Then
x = x + 1
Else
GetBlockCount = x
Exit Function
End If
End If
End Function
Any help would be much appreciated.
I think you need to clean it out and make it more readable. Then look at it and the solution will be much clearer.
Here is a simple skeleton of what it should look like:
I = 100
Txt = Get100Requests(I)
Do While Txt <> ""
'use txt
I = I + 100
Txt = Get100Requests(I)
Loop
Function Get100Requests(FromItem As Integer) As String
If FromItem => frmEngineCampaignSearch.lstbxESNNumbers.ListCount Then Exit Function
Dim I As Integer
I + FromItem
Do While I < FromItem + 99 And I < frmEngineCampaignSearch.lstbxESNNumbers.ListCount
Get100Requests = Get100Requests & "'" & frmEngineCampaignSearch.lstbxESNNumbers.list(i) & "', "
I = I + 1
Loop
Get100Requests = Left(Get100Requests, Len(Get100Requests)-2)
Exit Function
Private Sub Command4_Click()
Dim x As Integer
r = InputBox("Enter row size ")
c = InputBox("Enter column size ")
ReDim arr(r, c) As Integer
For i = 0 To r - 1 Step 1
For j = 0 To c - 1 Step 1
arr(i, j) = InputBox("Enter row : " & (i + 1) & "column size : " & (j + 1))
Next j
Next i
For i = 0 To r - 1
For j = 0 To c - 1
Text1.Text = Text1.Text & " " & arr(i, j)
Next j
Text1.Text = Text1.Text & vbNewLine & vbCr
Next i
End Sub
This is my code for taking inputs in an array. Here everything is working fine except this line "Text1.Text = Text1.Text & vbNewLine & vbCr" here I am trying to print the array in row-column in 2D form inside a text box but its not happening "vbNewLine or vbcr" both are not working and my array is getting printed in a single line.
I suggest vbCrLf instead of vbNewLine & vbCr, and you need to make sure you have your textbox set to Multiline in the properties editor.