I have a spreadsheet where I want to have:
1) A source cell, which will have a string such as D2594D8-8.
You can see this is a string of hexadecimal digits without a delimiter except the single dash
2)a group of label and "target" cells where a macro will copy each individual hex digit from the source cell individually.
So an example would be:
Step 1: Enter into D1 the value: D2594D8-8
Step 2: Run the macro
Step 3: the values of the cells:
C4 updated to equal "D" (The first character from the source cell string)
D4 updated to equal "2" (The second character from the source cell string)
E4 updated to equal "5" (The thrid character from the source cell string)
etc....
I currently am trying:
Sub AssignData()
Dim wldData As Variant
UWParray = Array(Range("D1"))
Range("D4").Value = UWParray(0)
Range("D5").Value = UWParray(1)
Range("D6").Value = UWParray(2)
Range("D7").Value = UWParray(3)
End Sub
But that only gets me:
"Run-time error '9'
Subscript out or Range
and the result:
1 D2594D8-8
2
3
4
5
6
7
Any help would be appreciated!
Thanks in advance
Your code is taking the entire D1 value and putting it into the first position of the array, so when it goes to look for the second position, it doesn't exist--hence the "subscript out of range" error. The below code works.
Sub AssignData()
Dim wldData As Variant
Dim UWParray() As String
Dim i As Integer
ReDim UWParray(Len(Range("D1").Value))
For i = 0 To Len(Range("D1").Value)
UWParray(i) = Mid(Range("D1").Value, i + 1, 1)
Next
Range("D4").Value = UWParray(0)
Range("D5").Value = UWParray(1)
Range("D6").Value = UWParray(2)
Range("D7").Value = UWParray(3)
End Sub
A one liner :)
[c4].Resize(1, Len([d1].Value)) = Application.Transpose(Evaluate("=index(mid(D1,ROW(1:" & Len([d1].Value) & "),1),)"))
This should do what your asking:
Dim my_array() As String
Dim my_String As String
Dim i As Integer
my_String = Range("D1").Value
'Replace "-" with nothing
my_String = Replace(my_String, "-", "")
'Split my string into individual characters and store in array/worksheet
ReDim my_array(Len(my_String) - 1)
For i = 1 To Len(my_String)
my_array(i - 1) = Mid(my_String, i, 1)
'Store values in excel sheet starting at C3
Cells(4, (2 + i)).Value = my_array(i - 1)
Next
You actually don't need to use an array to store the values into the worksheet's cells, but I added it because of the post title.
Related
I have an excel sheet with some rows of descriptions in a single column, what I am aiming is to get a vba that would go though all those rows of descriptions and truncate it upto certain character limit for example 30 characters and if the truncation stops at 30 character in the middle of the word then I want the complete word(could extend beyond 30 characters in this case).
I tried to do this with the VBA code below, but I am not able to get what I am looking for.
Function foo(r As Range)
Dim sentence As Variant
Dim w As Integer
Dim ret As String
' assign this cell's value to an array called "sentence"
sentence = Split(r.Value, " ")
' iterate each word in the sentence
For w = LBound(sentence) To UBound(sentence)
' trim to 6 characters:
sentence(w) = Left(sentence(w), 6)
Next
' Join the array back to a string/sentence
ret = Join(sentence, " ")
'Make sure the sentence is max 20 chars:
ret = Left(ret, 20)
'return the value to your function expression:
foo = ret
End Function
I expect the code to go through all the rows of a specific column and truncate it upto 30 characters and if the truncation stops in the middle of the word, then it should keep that word.
Since you tagged it for a formula
=LEFT(A1,FIND(" ",A1,30)-1)
I think you're looking for the instr() function. This could give you the first space-character after position 30.
You would get the following:
Dim SpacePosition as Integer
'return the position for the first space-character after position 29
SpacePosition = Instr(30, r.value," ")
if SpacePosition <> 0 then
'fill ret with the substring up to the first space after position 29
ret = left(r.value, SpacePosition - 1)
else
'if there is no space-character (after position 29) then take the whole string
ret = r.value
end if
Hope that helps.
Best & brilliant solution by #scott Craner. However, In you VBA code you may Change the followings to get required result
'Join the array back to a string/sentence
'ret = Join(sentence, " ")
ret = ""
For w = LBound(sentence) To UBound(sentence)
' trim to 6 characters:
sentence(w) = Left(sentence(w), 6)
ret = ret & IIf(Len(ret) > 0, " ", "") & sentence(w)
If Len(ret) >= 30 Then Exit For
Next w
'Make sure the sentence is max 20 chars:
' ret = Left(ret, 20)
Public Function foo(r As Range, length As Integer) As String
If Len(r.Value) <= length Then
foo = r.Value
Else
foo = Left(r.Value, 1 + length)
foo = RTrim(Left(foo, InStrRev(foo, " ")))
End If
End Function
I suppose you would want to run that by passing 20 as the 2nd parameter
Loop rows from sheet 1, column A starting from row 1:
Option Explicit
Sub test()
Dim Lastrow As Long, i As Long
With ThisWorkbook.Worksheets("Sheet1")
Lastrow = .Cells(.Rows.Count, "A").End(xlUp).Row
For i = 1 To Lastrow
'Insert Code
Next i
End With
End Sub
I try to learn VBA. This code:
Dim i As Integer
Dim damage As String
i = 1
Do While 1
damage = CStr(Worksheets("charakters").Range("d14").Value)
you_min_damage = CInt(Left(damage, i))
If Right(i, 0) = "-" Then
Trim (you_min_damage)
Exit Do
End If
i = i + 1
Loop
cause this problem (in 4 iteration):
In cell D14 I have "4 - 11". I want to separate first number nad change it to integer.
You_min_damage is integer.
Try this one:
Dim you_min_damage As Integer, you_max_damage As Integer
Dim arr
'store all values in array
arr = Split(Worksheets("charakters").Range("d14").Value, "-")
'get first value
you_min_damage = CInt(arr(0))
'get last value
you_max_damage = CInt(arr(UBound(arr)))
I'm trying to generate words in Column B from a list of given words in Column A.
Right now my code in Excel VBA does this:
Function GetText()
Dim GivenWords
GivenWords = Sheets(1).Range(Sheets(1).[a1], Sheets(1).[a20])
GetText = A(Application.RandBetween(1, UBound(A)), 1)
End Function
This generates a word from the list I have provided in A1:A20, but I don't want any duplicates.
GetText() will be run 15 times in Column B from B1:B15.
How can I check for any duplicates in Column B, or more efficiently, remove the words temporarily from the list once it has been used?
For example,
Select Range A1:A20
Select one value randomly (e.g A5)
A5 is in Column B1
Select Range A1:A4 and A6:A20
Select one value randomly (e.g A7)
A7 is in Column B2
Repeat, etc.
This was trickier than I thought. The formula should be used as a vertical array eg. select the cells where you want the output, press f2 type =gettext(A1:A20) and press ctrl+shift+enter
This means that you can select where your input words are in the worksheet, and the output can be upto as long as that list of inputs, at which point you'll start getting #N/A errors.
Function GetText(GivenWords as range)
Dim item As Variant
Dim list As New Collection
Dim Aoutput() As Variant
Dim tempIndex As Integer
Dim x As Integer
ReDim Aoutput(GivenWords.Count - 1) As Variant
For Each item In GivenWords
list.Add (item.Value)
Next
For x = 0 To GivenWords.Count - 1
tempIndex = Int(Rnd() * list.Count + 1)
Aoutput(x) = list(tempIndex)
list.Remove tempIndex
Next
GetText = Application.WorksheetFunction.Transpose(Aoutput())
End Function
Here's how I would do it, using 2 extra columns, and no VBA code...
A B C D
List of words Rand Rank 15 Words
Apple =RAND() =RANK(B2,$B$2:$B$21) =INDEX($A$2:$A$21,MATCH(ROW()-1,$C$2:$C$21,0))
copy B2 and C2 down as far as the list, and drag D down for however many words you want.
Copy the word list somewhere, as every time you change something on the sheet (or recalculate), you will get a new list of words
Using VBA:
Sub GetWords()
Dim Words
Dim Used(20) As Boolean
Dim NumChosen As Integer
Dim RandWord As Integer
Words = [A1:A20]
NumChosen = 0
While NumChosen < 15
RandWord = Int(Rnd * 20) + 1
If Not Used(RandWord) Then
NumChosen = NumChosen + 1
Used(RandWord) = True
Cells(NumChosen, 2) = Words(RandWord, 1)
End If
Wend
End Sub
Here is the code. I am deleting the cell after using it. Please make a backup of your data before using this as it will delete the cell contents (it will not save automatically...but just in case). You need to run the 'main' sub to get the output.
Sub main()
Dim i As Integer
'as you have put 15 in your question, i am using 15 here. Change it as per your need.
For i = 15 To 1 Step -1
'putting the value of the function in column b (upwards)
Sheets(1).Cells(i, 2).Value = GetText(i)
Next
End Sub
Function GetText(noofrows As Integer)
'if noofrows is 1, the rand function wont work
If noofrows > 1 Then
Dim GivenWords
Dim rowused As Integer
GivenWords = Sheets(1).Range(Sheets(1).Range("A1"), Sheets(1).Range("A" & noofrows))
'getting the randbetween value to a variable bcause after taking the value, we can delete the cell.
rowused = (Application.RandBetween(1, UBound(GivenWords)))
GetText = Sheets(1).Range("A" & rowused)
Application.DisplayAlerts = False
'deleting the cell as we have used it and the function should not use it again
Sheets(1).Cells(rowused, 1).Delete (xlUp)
Application.DisplayAlerts = True
Else
'if noofrows is 1, there is only one value left. so we just use it.
GetText = Sheets(1).Range("A1").Value
Sheets(1).Cells(1, 1).Delete (xlUp)
End If
End Function
Hope this helps.
I am new at excel VB and seek assistant in the following problem below:
I have a column A with following values below:
column A
"VL50s"
"M50s"
"H50s"
"VL50s"
"H50s"
I would like to extract the numbers and run the following arithmetic function below into coloumn B.
key:
x is a number
VLx --> (x) + 1
Mx -->(x) + 2
Hx --> (x) + 3
the output should look like the following using the key above:
coloumn B
51
52
53
51
53
I would like to ask how would i go about doing this function in VBA. Thank you for your assistance.
Because you say the number of letter/number combos is much greater than in your example I think this is a problem for VBA and not a worksheet function. A WS function would become to hard to maintain and to beastly very quickly.
I made these 4 functions. The GetCharArray function parses the text of the string you pass it to return that text as an array of characters (even though BA doesn't have a char type just a string type so I am returning a string. Same idea)
Then given that we can call GetNumberFromChars to get the 50 from VL50s and call GetLeftMostLetters to get the VL from VL50s.
Then is some worksheet I made a named range called keys where column 1 of the range is letters like "VL", "H", "M" ... and the corresponding value associated with it is in column 2. It would look like
Col1 Col2
VL 1
M 2
H 3
... ...
We can use the vlookup worksheet function with the Range("keys") and the result of GetLeftMostLetters to find the number that should be added to the result of GetNumberFromChars.
Function GetNewNumber(inString As String) As Double
Dim searchString As String, numberToAddFromKeys As Double, numberToAddToFromCell As Long, cellChars() As String
cellChars = GetCharArray(inString)
searchString = GetLeftMostLetters(cellChars)
numberToAddToFromCell = GetNumberFromChars(cellChars)
'use the keys named range where column 1 is your letters ("VL","H"...)
'and column 2 is the corresponding value for that letter set
numberToAddFromKeys = WorksheetFunction.VLookup(searchString, Range("keys"), 2, 0)
GetNewNumber = CDbl(numberToAddFromKeys) + CDbl(numberToAddToFromCell)
End Function
Function GetNumberFromChars(inChars() As String) As Long
Dim returnNumber As String, i As Long, numberStarted As Boolean
For i = 1 To UBound(inChars)
If IsNumeric(inChars(i)) Then
If Not numberStarted Then numberStarted = True
returnNumber = returnNumber & inChars(i)
Else
If numberStarted Then
'this will ignore that "s" on the end of your sample data
'hopefully that's what you need
GetNumberFromChars = returnNumber
Exit Function
End If
End If
Next
End Function
Function GetLeftMostLetters(inChars() As String) As String
Dim returnString As String, i As Long
For i = 1 To UBound(inChars)
If Not IsNumeric(inChars(i)) Then
returnString = returnString & inChars(i)
Else
GetLeftMostLetters = returnString
End If
Next
End Function
Function GetCharArray(inText As String) As String()
Dim s() As String, i As Long
ReDim s(1 To Len(inText))
For i = 1 To UBound(s)
s(i) = Mid$(inText, i, 1)
Next
GetCharArray = s
End Function
So it can be used as such...
Dim cell As Range, rng As Range
'set this range to your actual range.
Set rng = Sheets("your sheet name").Range("A1:A5")
For Each cell In rng
'put this resulting value wherever you want.
Debug.Print GetNewNumber(cell.Value)
Next cell
You don't even have to use VBA for that, you can use a (very ugly) formula to determine this:
=SUBSTITUTE(SUBSTITUTE(SUBSTITUTE(SUBSTITUTE(A1, "VL",""), "M",""), "H", ""),
"s", "") + IF(LEFT(A1, 2) = "VL", 1, IF(LEFT(A1, 1) = "M", 2,
IF(LEFT(A1,1) = "H", 3, 0)))
In reality this formula should be on one line, but I've broken it up here so that it's readable. Place the formula in cell B1, and then copy it down to any other cells you need. It strips out all instances of "VL", "M", "H" and "s", and then adds the extra number based on the left 1 or 2 characters of the A cell.
This will return the first number found in the input value:
Function GetNumber(val)
Dim re As Object
Dim allMatches
Set re = CreateObject("VBScript.RegExp")
re.Pattern = "(\d+)"
re.ignorecase = True
re.Global = True
Set allMatches = re.Execute(val)
If allMatches.Count > 0 Then
GetNumber = allMatches(0)
Else
GetNumber = ""
End If
End Function
EDIT: just noticed your question title says "decimal" numbers - will your values have any decimal places, or all they all whole numbers?
In a program that I'm trying to write now I take two columns of numbers and perform calculations on them. I don't know where these two columns are located until the user tells me (they input the column value in a cell in the workbook that my code is located in).
For example, if the user inputted "A" and "B" as the columns where all the information is in I can perform calculations based on those values. Likewise if they wanted to analyze another worksheet (or workbook) and the columns are in "F" and "G" they could input those. The problem is that I'm asking the user to input those two columns as well as four others (the last four are the result columns). I did this in hopes that I would be able to make this flexible, but now inflexibility is acceptable.
My question is, if I'm given a value of where some information will be (let's say "F") how can I figure out what the column will be after or before that inputted value. So if I'm only given "F" I'll be able to create a variable to hold the "G" column.
Below are examples of how the variables worked before I needed to do this new problem:
Dim first_Column As String
Dim second_Column As String
Dim third_Column As String
first_Column = Range("B2").Text
second_Column = Range("B3").Text
third_Column = Range("B4").Text
Here the cells B2 - B4 are where the user inputs the values. Generally I want to be able to not have the B3 and B4 anymore. I feel like the Offset(0,1) might be able to help somehow but so far I've been unable to implement it correctly.
Thank you,
Jesse Smothermon
Here are two functions that will help you dealing with columns > "Z". They convert the textual form of a column to a column index (as a Long value) and vice versa:
Function ColTextToInt(ByVal col As String) As Long
Dim c1 As String, c2 As String
col = UCase(col) 'Make sure we are dealing with "A", not with "a"
If Len(col) = 1 Then 'if "A" to "Z" is given, there is just one letter to decode
ColTextToInt = Asc(col) - Asc("A") + 1
ElseIf Len(col) = 2 Then
c1 = Left(col, 1) ' two letter columns: split to left and right letter
c2 = Right(col, 1)
' calculate the column indexes from both letters
ColTextToInt = (Asc(c1) - Asc("A") + 1) * 26 + (Asc(c2) - Asc("A") + 1)
Else
ColTextToInt = 0
End If
End Function
Function ColIntToText(ByVal col As Long) As String
Dim i1 As Long, i2 As Long
i1 = (col - 1) \ 26 ' col - 1 =i1*26+i2 : this calculates i1 and i2 from col
i2 = (col - 1) Mod 26
ColIntToText = Chr(Asc("A") + i2) ' if i1 is 0, this is the column from "A" to "Z"
If i1 > 0 Then 'in this case, i1 represents the first letter of the two-letter columns
ColIntToText = Chr(Asc("A") + i1 - 1) & ColIntToText ' add the first letter to the result
End If
End Function
Now your problem can be solved easily, for example
newColumn = ColIntToText(ColTextToInt(oldColumn)+1)
EDITED accordingly to the remark of mwolfe02:
Of course, if you are not interested in the column names, but just want to get a range object of a specific cell in a given row right beneath a column given by the user, this code is "overkill". In this case, a simple
Dim r as Range
Dim row as long, oldColumn as String
' ... init row and oldColumn here ...
Set r = mysheet.Range(oldColumn & row).Offset(0,1)
' now use r to manipulate the cell right to the original cell
will do it.
You were on the right track with Offset. Here is a test function that shows a couple different approaches to take with it:
Sub test()
Dim first_Column As String
Dim second_Column As String
Dim third_Column As String
Dim r As Range
first_Column = Range("B2").Text
second_Column = Range("B2").Offset(1, 0).Text
third_Column = Range("B2").Offset(2, 0).Text
Debug.Print first_Column, second_Column, third_Column
Set r = Range("B2")
first_Column = r.Text
Set r = r.Offset(1, 0)
second_Column = r.Text
Set r = r.Offset(1, 0)
third_Column = r.Text
Debug.Print first_Column, second_Column, third_Column
End Sub
UPDATE: After re-reading your question I realize you were trying to do offsets based on a user-entered column letter. #rskar's answer will shift the column letter, but it will be a lot easier to work with the column number in code. For example:
Sub test()
Dim first_Col As Integer, second_Col As Integer
first_Col = Cells(, Range("B2").Text).Column
second_Col = first_Col + 1
Cells.Columns(first_Col).Font.Bold = True
Cells.Columns(second_Col).Font.Italic = True
End Sub
There are a few syntactical problems with #rskar's answer. However, it was helpful in producing a function that grabs a column "letter", based on an input column "letter" and a desired offset to the right:
Public Function GetNextCol(TheCol As String, OffsetRight As Integer) As String
Dim TempCol1 As String
Dim TempCol2 As String
TempCol1 = Range(TheCol & "1").Address
TempCol2 = Range(TempCol1).Offset(0, OffsetRight).Address(0, 0, xlA1)
GetNextCol = Left(TempCol2, Len(TempCol2) - 1)
End Function
In light of the comments of others (and they all raised valid points), here is a much better solution to the problem, using Offset and Address:
Dim first_Column As String
Dim second_Column As String
Dim p As Integer
first_Column = Range("B2").Text
second_Column = _
Range(first_Column + ":" + first_Column).Offset(0, 1).Address(0, 0, xlA1)
p = InStr(second_Column, ":")
second_Column = Left(second_Column, p - 1)
The above should work for any valid column name, "Z" and "AA" etc. included.
Make use of the Asc() and Chr() functions in VBA, like so:
Dim first_Column As String
Dim second_Column As String
first_Column = Range("B2").Text
second_Column = Chr(Asc(first_Column) + 1)
The Asc(s) function returns the ASCII code (in integer, usually between 0 and 255) of the first character of a string "s".
The Chr(c) function returns a string containing the character which corresponds to the given code "c".
Upper case letters (A thru Z) are ASCII codes 65 thru 90. Just google ASCII for more detail.
NOTE: The above code will be fine so long as the first_Column is between "A" and "Y"; for columns "AA" etc., it will take a little more work, but Asc() and Chr() will still be the ticket to coding for that.