The code snippet below is attempting to look at the contents of a column of cells. Each cell is formatted: "X.XX_-_X.XX". For example: 5.66 - 13.44. The code is meant to take each cell, convert each of the strings to a double, compare them to some other numbers and then repeat for the next cell.
Sub Test()
Dim PC As Worksheet
Dim i As Integer
Dim MaxSpace, MinSpace As Double
Dim MinMax() As String
Set PC = Workbooks("RFQ_Worksheet").Worksheets("Press Choice")
For i = 7 To 52
MinMax = Split(PC.Cells(i, 8), " - ", 2)
MaxSpace = CDbl(MinMax(1))
MinSpace = CDbl(MinMax(0))
If MaxSpace > 10.3 Then
'Do some stuff
End If
Next i
End Sub
The line containing MaxSpace = CDbl(MinMax(1)) gives a 'Subscript out of range' error. However, when I replace PC.Cells(i, 8) with PC.Cells(7, 8), the code runs fine.
What am I missing here?
Basically, you are hitting cells in your loop that don't have the delimiter.
Fix:
Sub Test()
Dim PC As Worksheet
Dim i As Integer
Dim MaxSpace As Double 'you didn't declare it properly
Dim MinSpace As Double
Dim MinMax() As String
Dim r As Range
Set PC = ThisWorkbook.Worksheets("Press Choice")
For i = 7 To 52
Set r = PC.Cells(i, 8)
If InStr(r, " - ") <> 0 Then
MinMax = Split(PC.Cells(i, 8), " - ", 2)
MaxSpace = CDbl(MinMax(1))
MinSpace = CDbl(MinMax(0))
'... etc
End If
Next i
End Sub
Related
Dear experts in Excel and VBA!
Could you tell me how you can color a certain line (condition - the presence of a certain word) in a Comments?
Comment consists of several lines, separated by Chr (10).
Example in picture1:
the comment has 4 lines, the second line contains the word "VBA", so this line should be highlighted in red.
The main problem is that the test word "VBA" can be in any line, there can be from 1 to 10+ lines.
I assumed that:
can move data from comment to cell
replace Chr (10) with some character, for example, "_"
distribute the text of the cell into columns through the "column distribution wizard"
search for the desired word "VBA" in the received cells
determine the cell number and understand that this is the number of the required line in the comment
based on the cell number, paint over the line number in the comment
Can you please tell me if my action logic is correct? Am I heading in the right direction?
If so, what is the correct way to carry out points 4-6?
enter image description here
would this help?
"test" is the codename for the sheet I have set, change it according to your situation.
"i" will give you the line number, starting from 0. So in your example it would be 1.
Edit: Added Exit For in the if check.
Option Explicit
Sub test_note()
Dim strNote As String
Dim arrNote As Variant
Dim number_of_lines As Integer
strNote = test.Range("A5").NoteText
number_of_lines = Len(strNote) - Len(Replace(strNote, Chr(10), "")) + 1
ReDim arrNote(1 To number_of_lines) As String
arrNote = Split(strNote, Chr(10))
Dim i As Long
For i = LBound(arrNote) To UBound(arrNote)
If InStr(arrNote(i), "VBA") > 0 Then
Debug.Print i, arrNote(i)
Exit For 'If you are sure there won't be any other occurrence of VBA in there, why check the rest of the lines? Speeds code depending on circumstance.
End If
Next i
End Sub
Edit 2: Revised code to change the color of the comment line.
Sub test_note()
Dim strNote As String
Dim arrNote As Variant
Dim number_of_lines As Integer
strNote = test.Range("B5").NoteText
number_of_lines = Len(strNote) - Len(Replace(strNote, Chr(10), "")) + 1
ReDim arrNote(1 To number_of_lines) As String
arrNote = Split(strNote, Chr(10))
Dim i As Long
Dim startPos As Integer
Dim number_of_chars As Integer
startPos = 1
' Reset comment font color
test.Range("B5").Comment.Shape.TextFrame.Characters.Font.Color = 0
For i = LBound(arrNote) To UBound(arrNote)
If InStr(arrNote(i), "VBA") > 0 Then
number_of_chars = Len(arrNote(i))
test.Range("B5").Comment.Shape.TextFrame.Characters(startPos, number_of_chars).Font.Color = vbRed
Debug.Print i, arrNote(i), "startPos: " & startPos, "numChars: " & number_of_chars
Else
startPos = startPos + Len(arrNote(i)) + 1
End If
Next i
End Sub
Check this. Just running this VBA copies your comments to the cells
and highlights the lines containing "VBA", however, it does this for
all comments on all sheets
credit: https://martinbosanacvba.blogspot.com/2021/08/copying-comments-to-cells-and.html
Sub Demo()
Dim tnahqb1 As Range
Dim tnahqb2 As Range
Dim tnahqb3 As Workbook
Dim tnahqb4 As Worksheet
Dim tnahqb5 As Variant
Dim tnahqb6 As Integer
Dim tnahqb7 As Integer
Dim tnahqb8 As Integer
Dim tnahqb9 As Integer
For Each tnahqb10 In ActiveWorkbook.Worksheets
Set tnahqb1 = tnahqb10.Cells.SpecialCells(xlCellTypeComments)
If tnahqb1 Is Nothing Then
MsgBox "No comments in the sheet"
Else
For Each cell In tnahqb1
cell.Value = cell.Comment.Text
tnahqb5 = Split(cell.Comment.Text, Chr(10))
tnahqb6 = UBound(tnahqb5) - LBound(tnahqb5) + 1
For I = LBound(tnahqb5) To UBound(tnahqb5)
If InStr(tnahqb5(I), "VBA") > 0 Then
tnahqb8 = Len(tnahqb5(I))
With cell
tnahqb7 = InStr(cell.Comment.Text, tnahqb5(I))
tnahqb9 = tnahqb7 + tnahqb8
.Characters(tnahqb7, tnahqb8).Font.Color = vbRed
End With
End If
Next I
Next cell
End If
Next tnahqb10
End Sub
I'm new to VBA, so thank you in advance for your patience. I wrote a sub that takes the part number (PN) in Range C2 and performs three different split and left functions to fill in the columns to the left and right of the PN with extracted portions of the PN string. Here is a screenshot of the columns and what it fills in.
Here is my code so far:
Sub PN_Autotfill1()
Dim PN As Range
Dim SCPort_Type As Range
Dim SCPort_Size As Range
Dim Start_FittingSize As Range
Dim PN_String As String
Dim PN_1 As Variant
Dim PN_2 As Variant
Dim PN_3 As Variant
Set PN = Range("C2")
Set SCPort_Type = PN.Offset(, -2)
Set SCPort_Size = PN.Offset(, -1)
Set Start_FittingSize = PN.Offset(, 1)
PN_String = PN.Value
If InStr(PN_String, "Flange") > 0 Then
'Splits PN into SC Port Type
PN_1 = Split(PN_String, "#")(1)
PN_2 = Left(PN_1, 2)
SCPort_Type.Value = "#" & PN_2 & "Flange"
'Splits PN into SC Port Size, Start, and End Fitting
PN_3 = Split(PN_1, "-")(1)
SCPort_Size = PN_3
Start_FittingSize = PN_3
End If
End Sub
Now I want to make a loop that applies these functions to each cell containing a PN in column C. I've found some good examples on Stackoverflow and a VBA tutorial website that create loops for a single split function, but not for multiple split functions. It looks like two For loops will come into play: LastRow = Cells(Rows.Count, "C").End(xlUp).Row with For a = 2 To LastRow, and For i = 1 To UBound(Unsure what goes here). Does anyone have tips or example code for how to go about this? Thank you in advance for any help!
Here is the code with Jamheadart's answer integrated in:
Sub PN_Autotfill_Functions(PN As Range)
Dim SCPort_Type_Size As Range
Dim Start_FittingSize As Range
Dim PN_String As String
Dim LastRow As Single
Dim PN_1 As Variant
Dim PN_2 As Variant
Dim PN_3 As Variant
Set SCPort_Type_Size = PN.Offset(, -1)
Set Start_FittingSize = PN.Offset(, 1)
PN_String = PN.Value
LastRow = Cells(Rows.Count, "C").End(xlUp).Row
If InStr(PN_String, "Flange") > 0 Then
'Splits PN into SC Port Type and Size, then combines results
PN_1 = Split(PN_String, "#")(1)
PN_2 = Left(PN_1, 2)
PN_3 = Split(PN_1, "-")(1)
SCPort_Type_Size.Value = "#" & PN_2 & " Flange" & ", -" & PN_3
'Fills in Start and End Fitting Size based on previous Split of PN
Start_FittingSize = PN_3
End If
End Sub
Sub PN_Autofill_Loop()
Dim a As Long
Dim PN As Range
Set PN = ActiveCell
For a = 2 To 11
PN_Autotfill_Functions Range("C" & a)
Next a
End Sub
You don't need multiple loops, you just need to run your sub in a loop - and each time you run it, it will take in a range (e.g. C2)
So change your routine first line to this:
Sub PN_Autotfill1(PN as Range)
And get rid of these two lines:
Dim PN As Range
Set PN = Range("C2")
This means PN is now a parameter for the routine, instead of it being defined in the routine itself.
You could then call it for a few ranges, like this:
Sub Testing()
PN_Autotfill1 Range("C2")
PN_Autotfill1 Range("C4")
PN_Autotfill1 Range("C7")
End Sub
And finally if you want to loop through say ten rows you could call it in a loop with a different sub routine:
Sub LoopingExample
Dim i As Long
For i = 2 to 11
PN_Autotfill1 Range("C" & i)
Next i
End Sub
It's worth noting that this ease is only possible because your original code is constructed quite well (e.g. it's using Offset instead of hard-coded ranges etc.)
I am working on a program that needs to read an array of values from cells in another worksheet in the same workbook. I am able to read a single value just fine, but when I try to read multiple, I cannot return an array.
Here is what I am trying to do:
Dim list() As Variant
list = ActiveWorkbook.Worksheets("Sheet2").Range("A2:C2").value
Debug.Print TypeName(list)
Debug.Print UBound(list)
Debug.Print LBound(list)
Debug.Print TypeName(list(UBound(list)))
For which the output is:
Variant()
1
1
Subscript out of range
However, If I try it where I expect a single string, instead of an array of strings
Dim value As String
Let value = ActiveWorkbook.Worksheets("Site IDs and CJONs").Range("A2").value
Debug.Print TypeName(value)
Debug.Print value
for which I get the output
String
Expected Value
According to this question I should be able to simply return an array from the range function (example from the answer below), but it doesn't seem to be working for me. What am I doing wrong?
Dim DirArray As Variant
DirArray = Range("a1:a5").Value
Although it is not obvious, this:
Dim DirArray As Variant
DirArray = Range("a1:a5").Value
actually is like:
Dim DirArray(1 To 5, 1 To 1) As Variant
DirArray(1, 1) = Range("A1").Value
DirArray(2, 1) = Range("A2").Value
DirArray(3, 1) = Range("A3").Value
DirArray(4, 1) = Range("A4").Value
DirArray(5, 1) = Range("A5").Value
Pulling a set of cells into an array usually makes a 2-D array.
NOTE:
If you want to go from array to worksheet cells then, for example:
Sub ytrewq()
Dim DirArray(1 To 5, 1 To 1) As Variant
DirArray(1, 1) = "Larry"
DirArray(2, 1) = "Moe"
DirArray(3, 1) = "Curly"
DirArray(4, 1) = "Shepp"
DirArray(5, 1) = "James"
Range("B9").Resize(5, 1) = DirArray
End Sub
I might as well put my comment as an answer:
Option Explicit
Sub test()
Dim list As Variant
list = Application.Transpose(Application.Transpose(ActiveWorkbook.Worksheets("Sheet1").Range("A2:C2").Value))
Debug.Print TypeName(list)
Debug.Print UBound(list)
Debug.Print LBound(list)
'Debug.Print UBound(list, 2) Error
'Debug.Print LBound(list, 2) Error
Debug.Print TypeName(list(UBound(list)))
Debug.Print list(UBound(list))
End Sub
Gives output:
Variant()
3
1
String
x
where C2 contains letter x.
I have code I created with the help of the internet.
It loops through a list to find a specific string. Then it takes column B cell and pastes it onto another workbook.
But I have two different strings in the list. each time my code overwrites the first string.
I want to concatenate the two but with a comma between. e.g. [16, 5]
DATA
[C]_GA-M126_ST16_1.5_1 16
[C]_GA-M126_ST16_1.5_2 16
[C]_GA-M126_ST16_1.5_3 16
[C]_GA-M126_ST16_1.5_4 16
[C]_GA-M126_ST16_1.5_159 5
[C]_GA-M126_ST16_1.5_160 5
[C]_GA-M126_ST16_1.5_161 5
[C]_GA-M126_ST16_1.5_162 5
Sub POP_LT_UNC()
Dim W_DIP As Workbook
Dim W_PD As Workbook
Dim WDir As String
Dim CTRL As String
Dim PD_CTRL As Long
Dim nRow As Long
Dim I As Long
Dim C As Long
Dim PD_CELL As Range
Dim firstaddress As String
Dim LT_NUM As String
Dim first_LT As String
Dim ALL_LT As String
'=============================
' Set Pointer to WorkSheets
'=============================
WDir = ActiveWorkbook.Path
W_PD_DIR = WDir & ".\_database\POINT-DATA-ALL COLLECTOINS_v2.xlsx"
Set W_DIP = ThisWorkbook
Workbooks.Open (W_PD_DIR)
Set W_PD = Workbooks("POINT-DATA-ALL COLLECTOINS_v2.xlsx")
GDETrow = 17
Do Until GDETrow = 41
GDETrow = GDETrow + 1
With W_PD.Sheets(1).Range("A:A")
CTRL = W_DIP.Sheets("AFTER_SURVEY").Cells(GDETrow, 2)
Set PD_CELL = Range("A:A").Find(What:=CTRL)
If Not PD_CELL Is Nothing Then
firstaddress = PD_CELL.Address
Do
cRow = PD_CELL.Row
LT_NUM = W_PD.Sheets(1).Cells(cRow, 2)
Set PD_CELL = .FindNext(PD_CELL)
first_LT = LT_NUM
ALL_LT = first_LT & ", " & LT_NUM
W_DIP.Sheets("AFTER_SURVEY").Cells(GDETrow, 19) = ALL_LT
Loop While Not PD_CELL Is Nothing And PD_CELL.Address <> firstaddress
End If
End With
Loop
W_PD.Close
End Sub
Assuming W_DIP.Sheets("AFTER_SURVEY").Cells(GDETrow, 19) = ALL_LT is the line where the text is written, you can to this:
Dim rangeToChange as Excel.Range
Set rangeToChange = W_DIP.Sheets("AFTER_SURVEY").Cells(GDETrow, 19)
If IsEmpty(rangeToChange.Value2) Then
rangeToChange.Value2 = ALL_LT
Else 'already text in the Cell, add value with comma
rangeToChange.Value2 = rangeToChange.Value2 & ", " & ALL_LT
End If
Just replace the Line above with the Code provided.
This will fill the Cell with the value provided and only add the comma if there already is value inside the Cell.
.Value2 is used to avoid an implicit call to the default property of the cell.
The "for-each cell in range" statement seems to be running through the same cell multiple number of times.
See the screenshot.
It runs through the cell that has the word "Product" four time, because it is merged across four rows.
Is there a way to make it run only once, regardless of the design of the worksheet (in other words, I prefer not to use the fact that it is merged across four rows to be taken into account when coding).
Public Sub ProcessBeijingFile(Excel_UNC_Path As String)
Dim src As Workbook
Dim ProdPushWorkbook As Workbook
Set ProdPushWorkbook = ActiveWorkbook
Set src = Workbooks.Open(Excel_UNC_Path, True, True)
Dim c As Range
Dim r As Range
Dim LastRow As Long
Dim text As String
src.Sheets("Page 1").Activate
src.ActiveSheet.Range("A1").Select
LastRow = src.ActiveSheet.Range("A30000").End(xlUp).Row
text = LastRow
text = "A2:BA" + CStr(text)
Set r = Range(text)
Dim i As Integer
For i = 1 To MaxItems
PONumber(i) = ""
Next
Dim PageCounter As Integer
PageCounter = 0
RecordCounter = 0
Dim NextPONumber As String
NextPONumber = ""
For Each c In r
If Left(Trim(c.Value), 5) = "PO No" Then
NextPONumber = Trim(Replace(c.Value, "PO No.:", ""))
NextPONumber = Trim(Replace(NextPONumber, "PO No:", ""))
End If
....
If you don't care about performance and just want simple code, below demonstrates how you can go about skipping MergedCells. It displays address and value of non empty cells from Cell B1 in Immediate window until it reach empty cell. Kind of what you need.
Option Explicit
Sub Sample()
Dim oRng As Range
Set oRng = Range("B1")
Do Until IsEmpty(oRng)
Debug.Print oRng.Address, oRng.Value
Set oRng = oRng.Offset(1)
Loop
Set oRng = Nothing
End Sub
David pointed me in the right direction.
Here is the key:
if c.MergeCells then
If Trim(GetFirstWord(c.MergeArea.Address, ":")) = c.Address Then
'the first of merged cells, then process, else don't process...
Function Needed:
Public Function GetFirstWord(ByVal SearchString As String, Optional ByVal Delimeter As String = " ") As String
If SearchString = "" Then
GetFirstWord = ""
Else
Dim ary As Variant
ary = Split(SearchString, Delimeter)
GetFirstWord = ary(LBound(ary))
End If
' GetFirstWord = ary(LBound(ary))
'GetFirstWord = ary(LBound(ary))
End Function