Where I work we keep a list of vehicles that we find with damages. These damage codes come in a few variations, and I would like to setup a VBA script in excel to auto change the contents of a cell with the correct formatting, but I don’t really use VBA scripting and the Excel data objects confuse me
Here are a few examples of what I would like
06071 – VBA Function – 06.07.1
031211 – VBA Function- 03.12.1(1)
0409237-VBA Function – 04.09.2(3,7)
040912 030713 –VBA Function – 04.09.1(2) 03.07.1(3) (some vehicles have multiple damages)
Basically any number past length 5 would put any numbers in the 6th position onward into the parentheses, separated by commas.
I could do this in just about any other language, it’s just with all the random Excel stuff I am having issue after issue.
It doesn’t seem to matter what I try, my code bugs out before I can make any progress past
Dim test
test = Worksheets(“Sheet1”).Range(“A:A”).Value
Worksheets(“Sheet2”).Range(“B:B”).Value=test
I tried to make a function which ended up not working no matter how I called it. If I could just basic formatting of these numbers, I could more than likely figure it out from there.
Thanks for any help you guys can give me
You can do this with a UDF (user defined function): Place the following code in a new module in VBA:
Function ConvertIt(rng As Range) As String
Dim varStr As Variant
Dim strSource As String, strResult As String
Dim i As Integer
For Each varStr In Split(Trim(rng.Value), " ")
strSource = CStr(varStr)
strResult = strResult & _
Mid(strSource, 1, 2) & "." & _
Mid(strSource, 3, 2) & "." & _
Mid(strSource, 5, 1)
If Len(strSource) > 5 Then
strResult = strResult & "("
For i = 6 To Len(strSource)
strResult = strResult & Mid(strSource, i, 1) & ","
Next i
strResult = Left(strResult, Len(strResult) - 1) & ")"
End If
strResult = strResult & " "
Next
ConvertIt = Left(strResult, Len(strResult) - 1)
End Function
Assuming that your data is in column A of your worksheet, place this formula in B2: =ConvertIt(A2) and copy it down. Done!
If you want to convert the cells in one rush and replace the source, use this code:
Sub ConvertAll()
Dim rng As Range
For Each rng In Range("A1:A100")
rng.Value = ConvertIt(rng)
Next
End Sub
Lightly-tested:
Function FormatStuff(v)
Dim i As Long, c As String, v2 As String, num As String
Dim num2 As String, x As Long
v2 = v
v = v & " "
For i = 1 To Len(v)
c = Mid(v, i, 1)
If c Like "#" Then
num = num & c
Else
If num <> "" And Len(num) >= 5 Then
num2 = Left(num, 2) & "." & Mid(num, 3, 2) & _
"." & Mid(num, 5,1)
If Len(num) > 5 Then
num2 = num2 & "("
For x = 6 To Len(num)
num2 = num2 & IIf(x > 6, ",", "") & Mid(num, x, 1)
Next x
num2 = num2 & ")"
End If
v2 = Replace(v2, num, num2)
End If
num = ""
End If
Next i
FormatStuff = v2
End Function
To answer your unasked question:
There are two reasons the code you supplied does not work.
Range("A:A") and Range("B:B") both select entire rows, but the
test variable can only hold content for one cell value at a time.
If you restrict your code to just one cell, using
Range("A1").value, for example, the code you have written will
work.
It seems you used different quotation marks than the
standard, which confuses the compiler into thinking "Sheet1", "A:A". etc. are variables.
With the range defined as one cell, and the quotation marks replaced, your code moves the value of cell A1 on Sheet1 to cell B1 on Sheet2:
Sub testThis()
Dim Test
Test = Worksheets("Sheet1").Range("A1").value
Worksheets("Sheet2").Range("B1").value = Test
End Sub
If you wanted to work down the entire column A on Sheet1 and put those values into the column B on Sheet2 you could use a loop, which just repeats an action over a range of values. To do this I've defined two ranges. One to track the cells on Sheet1 column A, the other to track the cells on Sheet2 column B. I've assumed there is no break in your data in column A:
Sub testThat()
Dim CellinColumnA As Range
Set CellinColumnA = Worksheets("Sheet1").Range("A1")
Dim CellinColumnB As Range
Set CellinColumnB = Worksheets("Sheet2").Range("B1")
Do While CellinColumnA.value <> ""
CellinColumnB.value = CellinColumnA.value
Set CellinColumnA = CellinColumnA.Offset(1, 0)
Set CellinColumnB = CellinColumnB.Offset(1, 0)
Loop
End Sub
Related
I have a column containing formulas as "strings", i.e. "=+I11+I192+I245+I280"
I need to replace the cells (I11, I192,I245andI280`) ID with the content (strings) contained in the cells themselves.
Example:
Cell X --> "=+I11+I192+I245+I280"
Cell I11 = 'A'
Cell I192 = 'B'
Cell I245 = 'C'
Cell I280 = 'D'
The formula should generate "=+A+B+C+D".
This?
="=+" & I11 &"+" & I192 &"+" & I245 & "+" & I280
Well, how about :
=I11 & I192 & I245 & I280
Or you can include spaces
=I11 & " " & I192
But straight quotes - my phone is being funny...
The formula should generate --> "=+A+B+C+D"
Try,
="=+"&textjoin("+", true, I11, I192, I245, I280)
Don't know what you will be doing with empty cells so here is draft
Public Sub test()
[I11] = "A": [I192] = "B": [I245] = "C": [I280] = "D"
Debug.Print ConvertedString("=+I11+I192+I245+I280")
End Sub
Public Function ConvertedString(ByVal inputString As String) As Variant
Dim arr() As String, i As Long
On Error GoTo errHand
If Not InStr(inputString, Chr$(43)) > 0 Then
ConvertedString = CVErr(xlErrNA)
Exit Function
End If
arr = Split(inputString, Chr$(43))
For i = 1 To UBound(arr)
arr(i) = Range(arr(i))
Next i
ConvertedString = Join(arr, Chr$(43))
Exit Function
errHand:
ConvertedString = CVErr(xlErrNA)
End Function
I think you mean something like
=INDIRECT(I11,TRUE)+INDIRECT(I192,TRUE)+INDIRECT(I245,TRUE)+INDIRECT(I280,TRUE)
but please note that Indirect is a volatile function, and can slow your calculations down if used extensively.
Using VBA (with only single delimiter):
Function ReplaceAddr(sInput As String, Optional sDelimiter As String = "+") As String
Dim sArr
Dim i As Long
sArr = Split(sInput, sDelimiter)
For i = 1 To UBound(sArr)
sArr = Range(sArr(i))
Next i
ReplaceAddr = Join(sArr, sDelimiter)
End Function
From OP's comment:
The problem is that formulas changes, so I can't only change manually. The one I gave you is only an example, but I have so many different ones with all math operators.
You can try finding cell addresses with regular expression and replace with cell's value:
Function ReplaceAddr2(sInput As String) As String
Dim oRegEx As Object
Dim oMatches As Object
Dim i As Long, lStart As Long, lLength As Long
Set oRegEx = CreateObject("vbscript.regexp")
oRegEx.Pattern = "[A-Za-z]{1,3}\d{1,7}"
oRegEx.Global = True
oRegEx.MultiLine = True
Set oMatches = oRegEx.Execute(sInput)
lStart = 0
For i = 0 To oMatches.Count - 1
lLength = oMatches(i).FirstIndex - lStart
ReplaceAddr2 = ReplaceAddr2 & Mid$(sInput, lStart + 1, lLength) & Range(oMatches(i).Value)
lStart = lStart + lLength + oMatches(i).length
Next
ReplaceAddr2 = ReplaceAddr2 & Mid(sInput, lStart + 1, Len(sInput) - lStart)
End Function
Pattern is 1-3 letters followed by 1-7 digits.
Both functions are not volatile - will be recalculated only when input string changes, but not when cells addressed there change. Adding this line:
Application.Volatile True
will make it recalculate on every change, but it may affect performance.
Ok so I have two columns of data as follows
Personalisation Max Char | Personaisation Field
1x15x25 | Initial, Name, Date
Previously I was using the following vba function (As excel16 has no TEXTJOIN)
Function TEXTJOIN(delim As String, skipblank As Boolean, arr)
Dim d As Long
Dim c As Long
Dim arr2()
Dim t As Long, y As Long
t = -1
y = -1
If TypeName(arr) = "Range" Then
arr2 = arr.Value
Else
arr2 = arr
End If
On Error Resume Next
t = UBound(arr2, 2)
y = UBound(arr2, 1)
On Error GoTo 0
If t >= 0 And y >= 0 Then
For c = LBound(arr2, 1) To UBound(arr2, 1)
For d = LBound(arr2, 1) To UBound(arr2, 2)
If arr2(c, d) <> "" Or Not skipblank Then
TEXTJOIN = TEXTJOIN & arr2(c, d) & delim
End If
Next d
Next c
Else
For c = LBound(arr2) To UBound(arr2)
If arr2(c) <> "" Or Not skipblank Then
TEXTJOIN = TEXTJOIN & arr2(c) & delim
End If
Next c
End If
TEXTJOIN = Left(TEXTJOIN, Len(TEXTJOIN) - Len(delim))
End Function
This would change 1x15x25 into 1-1, 2-15, 3-25using the following formula
{=TEXTJOIN(", ",TRUE,ROW(INDIRECT("1:" & LEN(A1)-LEN(SUBSTITUTE(A1,"x",""))+1)) & " - " & TRIM(MID(SUBSTITUTE(A1,"x",REPT(" ",999)),(ROW(INDIRECT("1:" & LEN(A1)-LEN(SUBSTITUTE(A1,"x",""))+1)) -1)*999+1,999)))}
Due to the fact, my original method was not specific enough I've been forced to go back to the drawing board.
From the Above, I am wanting to produce the following.
1-2-Initial, 2-15-Name, 3-25-Date
I am a developer but not in visual basic and the worst part Is I know what I would do with a database and PHP just don't have enough knowledge to transfer that to excel.
So I need to either by formula or function
Take 2 Columns and split by a delimiter
Then count the entries on each (Maybe only one)
Then for each in the range create a new string adding the count-col1-col2
I cannot change the data as its given by the supplier
I have a basic understanding of VBA so explain don't belittle
UPDATED (DATA SNAPSHOTS)
This Example uses the formula above a little-jazzed up.
As you can see each row starts the count again Ignore the Personalization/Message line parts I can add these again later
I am in a mega rush so only whipped this up with one row of values (in A1 and B1)
I hope you can step through to understand it, wrap it in another loop to go through your 6000 rows, and change the msgbox to whatever output area you need... 6000 rows should be super quick:
Sub go()
Dim a() As String
Dim b() As String
Dim i As Long
Dim str As String
' split A1 and B1 based on their delimiter, into an array a() and b()
a() = Split(Range("A1").Value2, "x")
b() = Split(Range("B1").Value2, ",")
' quick check to make sure arrays are same size!
If UBound(a) <> UBound(b) Then Exit Sub
' this bit will need amended to fit your needs but I'm using & concatenate to just make a string with the outputs
For i = LBound(a) To UBound(b)
str = str & i + 1 & "-" & a(i) & "-" & b(i) & vbNewLine
Next i
' proof in the pudding
MsgBox str
End Sub
Sub test()
Dim rngDB As Range
Dim vR() As Variant
Dim i As Long
Set rngDB = Range("a2", Range("a" & Rows.Count).End(xlUp)) '<~~personaliation Max Char data range
ReDim vR(1 To rngDB.Count, 1 To 1)
For i = 1 To rngDB.Count
vR(i, 1) = textjoin(rngDB(i), rngDB(i, 2))
Next i
Range("c2").Resize(rngDB.Count) = vR '<~ result wil be recorded in Column C
End Sub
Function textjoin(rng1 As Range, rng2 As Range)
Dim vS1, vS2
Dim vR()
Dim i As Integer
vS1 = Split(rng1, "x")
vS2 = Split(rng2, ",")
ReDim vR(UBound(vS1))
For i = LBound(vS1) To UBound(vS1)
vR(i) = i + 1 & "-" & Trim(vS1(i)) & "-" & Trim(vS2(i))
Next i
textjoin = Join(vR, ",")
End Function
THANK YOU FOR ALL OF THE HELP
I went back to the drawing board having seen the above.
I learnt
That my original use of array formula and TEXTJOIN where over the top and hardly simplistic
That I can use VBA just like any other programming code :)
My Solution simplified from Dy.Lee
Function SPLITANDMERGE(arr1 As String, arr2 As String, Optional del1 As String = "x", Optional del2 As String = ",")
'Arr1 Split'
Dim aS1
'Arr2 Split'
Dim aS2
'Value Array'
Dim r()
'Value Count'
Dim v As Integer
'Split The Values'
aS1 = Split(arr1, del1)
aS2 = Split(arr2, del2)
'Count The Values'
ReDim r(UBound(aS1))
'For All The Values'
For v = LBound(aS1) To UBound(aS2)
'Create The String'
r(v) = "Personalisation_Line " & v + 1 & " - " & Trim(aS1(v)) & " Characters - [" & Trim(aS2(v)) & "]"
Next v
'Join & Return'
SPLITANDMERGE = Join(r, ", ")
End Function
I'm still working on it but I now get the following result.
Will Be Adding:
Value Count Comparison (If we have 4 and 5 Values return "-" to be picked up by conditional formatting)
Conditional plural values (If value 2 in the string is 0 then character instead of characters
If there are any pitfalls or errors anyone can see please do enlighten me. Im here to learn.
I have a column of cells. They need to be concatenated into a single string with multiple delimiters in between.
I need something like the result in column 2 from the values in column 1
Column 1 | column 2
a1 | 'a1'
a2 | 'a1';'a2'
a3 | 'a1';'a2';'a3'
a4 | 'a1';'a2';'a3';'a4'
a5 | 'a1';'a2';'a3';'a4';'a5'
Currently I use the following formula
Column 1 | Column 2
a1 | ="'"&a1&"'"&";"
a2 | =b1&"'"&a2&"'"&";"
a3 |
and copy it down the column B2.
Is there a VBA code that could help me do that. I did find some that would add a single delimiter ' between the cells but I could not modify it to add multiple delimiters.
It would be very helpful could share a VBA code for the same.
You can use the Join method in VBA with a given delimeter:
e.g.
someArray = Array("some", "words", "here")
Debug.Print "'" & Join(someArray, "';'") & "'"
'// will print:
'// 'some';'words';'here'
I know you asked for VBA, but you can do this with a formula:
In B2:
=IF(ROW()=2,TEXTJOIN(";",TRUE,"'"&B1,"'"&A2&"'"),TEXTJOIN(";",TRUE,B1,"'"&A2&"'"))
and drag down:
Or
In B1, use ="'"&A1&"'", then in B2 (and drag down):
=SUBSTITUTE(TEXTJOIN(";",TRUE,"'"&B1,"'"&A2&"'"),"'","",1)
You can achieve desired output using this formula:
=CONCATENATE(B2, " ; '", A3, "'")
First put value from cell A2 to B2 manually (using ="'" & A2 & "'" formula) and then paste this formula in cell B3 and drag it down.
Here is the result with updated formula:
UPDATE (Thanks to BruceWayne)
Enter the value in cell B2 using:
="'" & A2 & "'"
So it will take the first '
I would just do a simple loop like so.
Sub combineRows()
'start and end rows, assuming column A
Dim startRow, endRow As Integer
Dim myString, myAdd As String
startRow = 2
endRow = 6
For i = startRow To endRow
myAdd = "'" & Range("A" & i) & "'" & ";"
myString = myString + myAdd
Range("B" & i) = myString
Next i
End Sub
Here's my JoinRange function. It has a few more options than you're looking for.
Public Function JoinRange(rInput As Range, _
Optional sDelim As String = vbNullString, _
Optional sLineStart As String = vbNullString, _
Optional sLineEnd As String = vbNullString, _
Optional sBlank As String = vbNullString, _
Optional sQuotes As String = vbNullString, _
Optional IgnoreBlanks As Boolean = True) As String
Dim vaCells As Variant
Dim i As Long, j As Long
Dim lCnt As Long
Dim aReturn() As String
If rInput.Cells.Count = 1 Then
ReDim aReturn(1 To 1)
aReturn(1) = sQuotes & rInput.Value & sQuotes
Else
vaCells = rInput.Value
ReDim aReturn(1 To rInput.Cells.Count)
For i = LBound(vaCells, 1) To UBound(vaCells, 1)
For j = LBound(vaCells, 2) To UBound(vaCells, 2)
If Len(vaCells(i, j)) = 0 Then
If Not IgnoreBlanks Then
lCnt = lCnt + 1
aReturn(lCnt) = sQuotes & sBlank & sQuotes
End If
Else
lCnt = lCnt + 1
aReturn(lCnt) = sQuotes & vaCells(i, j) & sQuotes
End If
Next j
Next i
ReDim Preserve aReturn(1 To lCnt)
End If
JoinRange = sLineStart & Join(aReturn, sDelim) & sLineEnd
End Function
use it in B1 like
=JoinRange($A$1:A1,";")
and fill down.
For the sake of avoiding visual confusion, I will offer CHAR(39)&CHAR(59)&CHAR(39) in place of "';'".
In B1, use this:
=CHAR(39)&TEXTJOIN(CHAR(39)&CHAR(59)&CHAR(39), TRUE, A$1:A1)&CHAR(39)
Fill down.
... or if the end result is the only important thing,
=CHAR(39)&TEXTJOIN(CHAR(39)&CHAR(59)&CHAR(39), TRUE, A1:A5)&CHAR(39)
A single tick (aka single quote or ') is ASCII character 39 and a semi-colon is ASCII character 59.
I have a principal sheet (Launch Tracker) that needs to be updated from a database. I have put the extraction of the database on an adjacent sheet (LAT - Master Data).
What I would like to do is that if the value of the columns H, O, Q are similar then it would replace the lines from column "E" to "AL" on the (Launch Tracker), if there is no match I would like to add the entire line at the end of the (Launch Tracker) sheet.
I already have this code that was running when I made a test, but now it doesn't seem to be working and I cannot figure out why.
Option Explicit
Option Base 1
Dim Ttrak_concat, Tdata_concat, Derlig As Integer
Sub General_update()
Dim Cptr As Integer, D_concat As Object, Ref As String, Ligne As Integer, Lig As Integer
Dim Start As Single
Dim test 'for trials
Start = Timer
Application.ScreenUpdating = False
Call concatenate("LAT - Master Data", Tdata_concat)
Call concatenate("Launch Tracker", Ttrak_concat)
'collection
Set D_concat = CreateObject("scripting.dictionary")
For Cptr = 1 To UBound(Ttrak_concat)
Ref = Ttrak_concat(Cptr, 1)
If Not D_concat.exists(Ref) Then: D_concat.Add Ref, Ttrak_concat(Cptr, 2)
Next
'comparison between the sheets
Sheets("LAT - Master Data").Activate
For Cptr = 1 To UBound(Tdata_concat)
Ref = Tdata_concat(Cptr, 1) 'chaineIPR feuil data
Ligne = Tdata_concat(Cptr, 2) 'localisation sheet data
If D_concat.exists(Ref) Then
Lig = D_concat.Item(Ref) 'localisation sheet track
Else
Lig = Derlig + 1
End If
Sheets("LAT - Master Data").Range(Cells(Ligne, "E"), Cells(Ligne, "AL")).Copy _
Sheets("Launch Tracker").Cells(Lig, "E")
Next
Sheets("Launch Tracker").Activate
Application.ScreenUpdating = False
MsgBox "mise à jour réalisée en: " & Round(Timer - Start, 2) & " secondes"
End Sub
'---------------------------------------
Sub concatenate(Feuille, Tablo)
Dim T_coli, T_colp, T_colr, Cptr As Integer
Dim test
With Sheets(Feuille)
'memorizing columns H O Q
Derlig = .Columns("H").Find(what:="*", searchdirection:=xlPrevious).Row
T_coli = Application.Transpose(.Range("H3:H" & Derlig))
T_colp = Application.Transpose(.Range("O3:O" & Derlig))
T_colr = Application.Transpose(.Range("Q3:Q" & Derlig))
'concatenate for comparison
ReDim Tablo(UBound(T_colr), 2)
For Cptr = 1 To UBound(T_colr)
Tablo(Cptr, 1) = T_coli(Cptr) & " " & T_colp(Cptr) & " " & T_colr(Cptr)
Tablo(Cptr, 2) = Cptr + 2
Next
End With
End Sub
Would someone have the solution to my problem?
Thank you in advance :)
EDIT 11:48
Actually the code runs now but It doesn't work the way I need it to. I would like to update the information on my sheet Launch tracker from the LAT - Master data sheet when the three columns H, O and Q are the same. The problem is that I have checked and some lines present in the LAT - Master Data sheet are not being added into the Launch tracker sheet after running the macro... Does someone have any idea why ?
Agathe
A type mismatch means that you gave a function a parameter that has the wrong type. In your case that means that UBound can't deal with T_colr or ReDim can'T deal with UBound(T_colr). Since Ubound always returns an integer, it must be T_colr.
If Derlig=3 then Application.Transpose(.Range("Q3:Q" & Derlig)) won't return an array but a single value (Double, String or whatever). That's when UBound throws the error.
You will also get an error with T_coli(Cptr) etc.
What you could do to prevent this is to check if Derlig = 3 and treat that case individually.
If Derlig = 3 Then
ReDim Tablo(1, 2)
Tablo(1, 1) = T_coli & " " & T_colp & " " & T_colr
Tablo(1, 2) = 3
Else
ReDim Tablo(UBound(T_colr), 2)
For Cptr = 1 To UBound(T_colr)
Tablo(Cptr, 1) = T_coli(Cptr) & " " & T_colp(Cptr) & " " & T_colr(Cptr)
Tablo(Cptr, 2) = Cptr + 2
Next Cptr
End If
I am trying to lookup a value and return multiple values (whether it be in the same cell or spread out horizontally pasted in different columns)I have tried the following UDF and continue to get #VALUE as result.
Option Explicit
Function LookupCSVResults(lookupValue As Variant, lookupRange As Range, resultsRange As Range) As String
Dim s As String 'Results placeholder
Dim sTmp As String 'Cell value placeholder
Dim r As Long 'Row
Dim c As Long 'Column
Const strDelimiter = "|||" 'Makes InStr more robust
s = strDelimiter
For r = 1 To lookupRange.Rows.Count
For c = 1 To lookupRange.Columns.Count
If lookupRange.Cells(r, c).Value = lookupValue Then
'I know it's weird to use offset but it works even if the two ranges
'are of different sizes and it's the same way that SUMIF works
sTmp = resultsRange.Offset(r - 1, c - 1).Cells(1, 1).Value
If InStr(1, s, strDelimiter & sTmp & strDelimiter) = 0 Then
s = s & sTmp & strDelimiter
End If
End If
Next
Next
'Now make it look like CSV
s = Replace(s, strDelimiter, ",")
If Left(s, 1) = "," Then s = Mid(s, 2)
If Right(s, 1) = "," Then s = Left(s, Len(s) - 1)
LookupCSVResults = s 'Return the function
End Function
Formula in cell =LookupCSVResults(Lookup Value, Col of Lookup Value, Col of Return Value)
Can anyone help trouble shoot this or have another UDF that will provide similar result? Thanks.