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.
Related
Would like to include a value to all my cells in column G if there are blank in column K, else no change.
If ActiveSheet.Range("K").Value, Criteria1:=" = " Then ActiveSheet.Range("G").Value = "Promo"
Else
Exit Sub
In order to test all the values you need to loop through the column. My example assumes the data doesn't have more than 100'000 lines and that you were testing for " = " to be included... addapt as needed.
Sub TestColumnK()
For i = 1 To ActiveSheet.Range("K100000").End(xlUp).Row
If InStr(1, ActiveSheet.Range("K" & i).Value, "=") > 0 Then
ActiveSheet.Range("G" & i).Value = "Promo"
End If
Next i
End Sub
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
I'm trying to flag problematic cells and link the cell hyperlink to another cell to review later. Here is my code. Not all of the code is visible. I Called "i" and "j" as long. The error occurs on newLink = Range("AL" & i).Hyperlinks(1).Address claiming that it is "out of range." I think this means that it is calling something that doesn't exist, but to be honest i'm not sure.
If Range("AK" & i).Value = "On" Then
If Range("AL" & i).Value = 0 And Range("AM" & i).Value = 0 Then
Range("AL" & i, "AM" & i).Interior.ColorIndex = 6
'Cells("AL" & i) = H.Address'
ErrorCount = ErrorCount + 1
Dim newLink As String
newLink = Range("AL" & i).Hyperlinks(1).Address
Range("IV" & j).Hyperlinks.Add anchor:=Range("IV" & j), Address:=Range("IV" & j)
Range("IV" & j).Hyperlinks(1).Address = newLink
j = j + 1
End If
If there is no hyperlink attached to a cell then Range("foo").Hyperlinks.Count will return 0 and therefore you will get an 'Out of range' error.
You just need to wrap the newLink = ... statement in an If to check if there is already a hyperlink there. E.g.
If Range("AL" & i).Hyperlinks.Count = 1 Then
newLink = Range("AL" & i).Hyperlinks(1).Address
Else
'what else will you do?
End If
I have the following code, modified by #FreeMan from one of my previous questions. I want to find the text "Hours" in any row in the worksheet. Then, apply the code to the column containing that text. This code is supposed to do that, but it does not work for me for some reason. I would really appreciate your help with this. Thank you in advance.
Sub CeldasinInfo()
Dim i As Long, r As Range, coltoSearch As String
Dim Result as String
Dim ErrCount as integer
ErrCount = 0
coltoSearch = "A"
coltoSearch = Range("1:1").find(What:="Hours", LookIn:=xlValues, LookAt:=xlWhole).Column
Result = "No Value in:" & vbcrlf
For i = 1 To Range(coltoSearch & Rows.Count).End(xlUp).Row
Set r = Range(coltoSearch & i)
If Len(r.Value) = 0 Then
r.Interior.ColorIndex = 3 ' Red
r.Select
MsgBox "No Value, in " & r.Address
Result = Result & r.Address & vbcrlf
ErrCount = ErrCount + 1
if ErrCount Mod 10 = 0 then 'change to 15 or 20 or whatever works well
MsgBox Result
Result = "No Value in:" & vbcrlf
End If
Sheets("Results").Range("A" & Sheets("Results").Range("A" & Rows.Count).End(xlUp).Row).Offset(1, 0).Formula = r.Address
End If
Next
If ErrCount > 0 then
MsgBox "There were " & ErrCount & " errors detected." & vbcrlf & result
else
MsgBox "No errors detected"
End If
End Sub
You need to change these two lines of code:
For i = 1 To Range(coltoSearch & Rows.Count).End(xlUp).Row
Set r = Range(coltoSearch & i)
to:
For i = 1 To Cells(Rows.Count, coltoSearch).End(xlUp).Row
Set r = Cells(i, coltoSearch)
Remove line: coltoSearch = "A"
coltoSearch should be an integer.
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.