I have an application for which I am currently using a dictionary object (specifically, it's a dictionary of dictionaries of dictionaries, so each lookup has three steps, if that makes any sense!). I do a large number of lookups on these dictionaries and multiply the results together.
The problem is that in the previous version of the application, I used the VLookup function to accomplish this functionality, and it would error out when I would try to look up a key that didn't exist. Now, it returns a "Empty", which Excel is happy to multiply by whatever I already had and return a zero. This is hard to track, and I'd very much prefer for it to return an error like before.
Is there something I can change to get it to return the error like it would with a VLookup, or do I need to create a new class module to do this? A class module would likely require me to re-write a large amount of code, which I'd like to avoid (there are hundreds of lookups I would have to update in the code).
Thanks.
Here is some of my code:
This is the module I use to load in all the tables to the dictionary:
Sub LoadFactorsAndBaseRates()
Dim t As Double
t = Timer
Dim n As Name
Dim TempArray()
Dim dict1 As Dictionary
Dim dict2 As Dictionary
Dim i As Integer
Dim j As Integer
For Each n In ThisWorkbook.Names
If InStr(1, n.RefersTo, "#") <> 0 Or InStr(1, n.RefersTo, "\") Then GoTo skipname
If Not FactorLookup.Exists(n.Name) And n.RefersToRange.Parent.Name <> "Rate Matrix" And InStr(1, n.Name, "Print") = 0 And InStr(1, n.Name, "FilterDatabase") = 0 And n.Name <> "Policies" Then
Set dict1 = New Dictionary
On Error GoTo err1
TempArray = n.RefersToRange.Value
For j = 1 To n.RefersToRange.Columns.Count
On Error Resume Next
Set dict2 = New Dictionary
For i = 1 To UBound(TempArray, 1)
dict2.Add TempArray(i, 1), TempArray(i, j)
Next i
dict1.Add j, dict2
Next j
Erase TempArray
FactorLookup.Add n.Name, dict1
End If
skipname:
Next n
Exit Sub
err1:
If Err.number = 1004 Then Resume skipname
End Sub
And here is a sample of the lookup code:
CoverageColumn = 2
'Base Rate
Temp = FactorLookup("Base_Rates")(CoverageColumn)(State & "_" & Company & "_" & Terr)
If Vehicle <> "Snowmobile" Then
'Class 1
x = FactorLookup("Class1")(CoverageColumn)(State & "_" & Company & "_" & Class1)
Temp = xRound(Temp * x, 1)
'Class 2
x = FactorLookup("Class2")(CoverageColumn)(State & "_" & Company & "_" & Class2)
Temp = xRound(Temp * x, 1)
'Class 3
x = FactorLookup("Class3")(CoverageColumn)(State & "_" & Company & "_" & Class3)
Temp = xRound(Temp * x, 1)
'Class 4
x = FactorLookup("Class4")(CoverageColumn)(State & "_" & Company & "_" & Class4)
Temp = xRound(Temp * x, 1)
The code is basically just a bunch of pages of this: look up, multiply, round to the nearest tenth, repeat. Occasionally, there's a step where we add instead of multiplying.
The xRound function adds 0.0000001 and then uses the Round function to round to the indicated number of decimal places (to account for the weirdness of the Excel VBA round function).
You need to create a function to "wrap" your top-level dictionary so you can call it with the three "keys" and get back an error value if that combination doesn't exist.
Function DoFactorLookup(k1, k2, k3) As Variant
Dim d, d2, rv
rv = CVErr(xlErrNA) ' #N/A error value
If FactorLookup.exists(k1) Then
Set d = FactorLookup(k1)
If d.exists(k2) Then
Set d2 = d(k2)
If d2.exists(k3) Then
rv = d2(k3)
End If
End If
End If
DoFactorLookup = rv
End Function
Related
I have created a macro that allows me to open multiple files based on their names and copy sheets into one on another workbook. Now I would like to add some criteria, I determine the last row with data. I used this:
lstRow2 = alarms.Cells(alarms.Rows.Count, "A").End(xlUp).Row
And now i want to go through each row and check if column G of each rows contains strings like ("condenser", "pump", etc) if yes copy the row but not the whole row, only a series of columns belonging to the row (for example for each row that match my criteria copy those columns A-B-X-Z) and finally copy all that in another sheet.
Thanks for your help
Flexible filter solution with multi-criteria
This approach allows a multi criteria search defining a search array and using the Application.Index function in an advanced way. This solution allows to avoid loops or ReDim s nearly completely in only a few steps:
[0] Define a criteria array, e.g. criteria = Array("condenser", "pump").
[1] Assign data A:Z to a 2-dim datafield array: v = ws.Range("A2:Z" & n), where n is the last row number and ws the set source sheet object.
Caveat: If your basic data contain any date formats, it's strictly recommended to use the .Value2 property instead of the automatic default assignment via .Value - for further details see comment.
[2] Search through column G (=7th col) and build an array containing the found rows via a helper function: a = buildAr(v, 7, criteria).
[3] Filter based on this array a using the Application.Index function and reduce the returned column values to only A,B,X,Z.
[4] Write the resulting datafield array v to your target sheet using one command only: e.g. ws2.Range("A2").Resize(UBound(v), UBound(v, 2)) = v, where ws2 is the set target sheet object.
Main procedure MultiCriteria
Option Explicit ' declaration head of code module
Dim howMany& ' findings used in both procedures
Sub MultiCriteria()
' Purpose: copy defined columns of filtered rows
Dim i&, j&, n& ' row or column counters
Dim a, v, criteria, temp ' all together variant
Dim ws As Worksheet, ws2 As Worksheet ' declare and set fully qualified references
Set ws = ThisWorkbook.Worksheets("Sheet1") ' <<~~ change to your SOURCE sheet name
Set ws2 = ThisWorkbook.Worksheets("Sheet2") ' <<~~ assign to your TARGET sheet name
' [0] define criteria
criteria = Array("condenser", "pump") ' <<~~ user defined criteria
' [1] Get data from A1:Z{n}
n = ws.Range("A" & Rows.Count).End(xlUp).Row ' find last row number n
v = ws.Range("A2:Z" & n) ' get data cols A:Z and omit header row
' [2] build array containing found rows
a = buildAr(v, 7, criteria) ' search in column G = 7
' [3a] Row Filter based on criteria
v = Application.Transpose(Application.Index(v, _
a, _
Application.Evaluate("row(1:" & 26 & ")"))) ' all columns
' [3b] Column Filter A,B,X,Z
v = Application.Transpose(Application.Transpose(Application.Index(v, _
Application.Evaluate("row(1:" & UBound(a) - LBound(a) + 1 & ")"), _
Array(1, 2, 24, 26)))) ' only cols A,B,X,Z
' [3c] correct rows IF only one result row found or no one
If howMany <= 1 Then v = correct(v)
' [4] Copy results array to target sheet, e.g. starting at A2
ws2.Range("A2").offset(0, 0).Resize(UBound(v), UBound(v, 2)) = v
End Sub
Possible addition to check the filtered results array
If you want to control the results array in the VB Editor's immediate window, you could add the following section '[5] to the above code:
' [5] [Show results in VB Editor's immediate window]
Debug.Print "2-dim Array Boundaries (r,c): " & _
LBound(v, 1) & " To " & UBound(v, 1) & ", " & _
LBound(v, 2) & " To " & UBound(v, 2)
For i = 1 To UBound(v)
Debug.Print i, Join(Application.Index(v, i, 0), " | ")
Next i
1st helper function buildAr()
Function buildAr(v, ByVal vColumn&, criteria) As Variant
' Purpose: Helper function to check criteria array (e.g. "condenser","pump")
' Note: called by main function MultiCriteria in section [2]
Dim found&, found2&, i&, n&, ar: ReDim ar(0 To UBound(v) - 1)
howMany = 0 ' reset boolean value to default
For i = LBound(v) To UBound(v)
found = 0
On Error Resume Next ' avoid not found error
found = Application.Match(v(i, vColumn), criteria, 0)
If found > 0 Then
ar(n) = i
n = n + 1
End If
Next i
If n < 2 Then
howMany = n: n = 2
Else
howMany = n
End If
ReDim Preserve ar(0 To n - 1)
buildAr = ar
End Function
2nd helper function correct()
Function correct(v) As Variant
' Purpose: reduce array to one row without changing Dimension
' Note: called by main function MultiCriteria in section [3c]
Dim j&, temp: If howMany > 1 Then Exit Function
ReDim temp(1 To 1, LBound(v, 2) To UBound(v, 2))
If howMany = 1 Then
For j = 1 To UBound(v, 2): temp(1, j) = v(1, j): Next j
ElseIf howMany = 0 Then
temp(1, 1) = "N/A# - No results found!"
End If
correct = temp
End Function
Edit I. due to your comment
"In column G I have a sentence for example (repair to do on the condenser) and I would like that as soon as the word "condenser" appears it implies it respects my criteria I tried ("* condenser*", "cex") like if filename like "book" but it doesn't work on an array, is there a method for that?"
Simply change the logic in helper function buildAr() to search via wild cards by means of a second loop over the search terms (citeria):
Function buildAr(v, ByVal vColumn&, criteria) As Variant
' Purpose: Helper function to check criteria array (e.g. "condenser","pump")
' Note: called by main function MultiCriteria in section [2]
Dim found&, found2&, i&, j&, n&, ar: ReDim ar(0 To UBound(v) - 1)
howMany = 0 ' reset boolean value to default
For i = LBound(v) To UBound(v)
found = 0
On Error Resume Next ' avoid not found error
' ' ** original command commented out**
' found = Application.Match(v(i, vColumn), criteria, 0)
For j = LBound(criteria) To UBound(criteria)
found = Application.Match("*" & criteria(j) & "*", Split(v(i, vColumn) & " ", " "), 0)
If found > 0 Then ar(n) = i: n = n + 1: Exit For
Next j
Next i
If n < 2 Then
howMany = n: n = 2
Else
howMany = n
End If
ReDim Preserve ar(0 To n - 1)
buildAr = ar
End Function
Edit II. due to last comment - check for existing values in column X only
"... I saw the change you did but I wanted to apply the last simpler idea, (last comment ) not using the wild Card but instead to check if there's a value in column X."
Simply hange the logic in the helper function to check for existing values only by measuring the length of trimmed values in column 24 (=X) and change the calling code in the main procedure to
' [2] build array containing found rows
a = buildAr2(v, 24) ' << check for value in column X = 24
Note: Section [0] defining criteria won't be needed in this case.
Version 2 of helper function
Function buildAr2(v, ByVal vColumn&, Optional criteria) As Variant
' Purpose: Helper function to check for existing value e.g. in column 24 (=X)
' Note: called by main function MultiCriteria in section [2]
Dim found&, found2&, i&, n&, ar: ReDim ar(0 To UBound(v) - 1)
howMany = 0 ' reset boolean value to default
For i = LBound(v) To UBound(v)
If Len(Trim(v(i, vColumn))) > 0 Then
ar(n) = i
n = n + 1
End If
Next i
If n < 2 Then
howMany = n: n = 2
Else
howMany = n
End If
ReDim Preserve ar(0 To n - 1)
buildAr2 = ar
End Function
I would create an SQL statement to read from the various sheets using ADODB, and then use CopyFromRecordset to paste into the destination sheet.
Add a reference (Tools -> References...) to Microsoft ActiveX Data Objects. (Choose the latest version; it's usually 6.1).
The following helper function returns the sheet names as a Collection for a given Excel file path:
Function GetSheetNames(ByVal excelPath As String) As Collection
Dim connectionString As String
connectionString = _
"Provider=Microsoft.ACE.OLEDB.12.0;" & _
"Data Source=""" & excelPath & """;" & _
"Extended Properties=""Excel 12.0;HDR=No"""
Dim conn As New ADODB.Connection
conn.Open connectionString
Dim schema As ADODB.Recordset
Set schema = conn.OpenSchema(adSchemaTables)
Dim sheetName As Variant
Dim ret As New Collection
For Each sheetname In schema.GetRows(, , "TABLE_NAME")
ret.Add sheetName
Next
conn.Close
Set GetSheetNames = ret
End Function
Then, you can use the following:
Dim paths As Variant
paths = Array("c:\path\to\first.xlsx", "c:\path\to\second.xlsx")
Dim terms As String
terms = "'" & Join(Array("condenser", "pump"), "', '") & "'"
Dim path As Variant
Dim sheetName As Variant
Dim sql As String
For Each path In paths
For Each sheetName In GetSheetNames(path)
If Len(sql) > 0 Then sql = sql & " UNION ALL "
sql = sql & _
"SELECT F1, F2, F24, F26 " & _
"FROM [" & sheetName & "] " & _
"IN """ & path & """ ""Excel 12.0;"" " & _
"WHERE F7 IN (" & terms & ")"
Next
Next
'We're connecting here to the current Excel file, but it doesn't really matter to which file we are connecting
Dim connectionString As String
connectionString = _
"Provider=Microsoft.ACE.OLEDB.12.0;" & _
"Data Source=""" & ActiveWorkbook.FullName & """;" & _
"Extended Properties=""Excel 12.0;HDR=No"""
Dim rs As New ADODB.Recordset
rs.Open sql, connectionString
Worksheets("Destination").Range("A1").CopyFromRecordset rs
Something like this maybe:
j = 0
For i = To alarms.Rows.Count
sheetname = "your sheet name"
If (Sheets(sheetname).Cells(i, 7) = "condenser" Or Sheets(sheetname).Cells(i, 7) = "pump") Then
j = j + 1
Sheets(sheetname).Cells(i, 1).Copy Sheets("aff").Cells(j, 1)
Sheets(sheetname).Cells(i, 2).Copy Sheets("aff").Cells(j, 2)
End If
Next i
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 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 remove items from the dictionary which are already selected from the comboboxes. I have a following code but i dont know what the problem is.It gives me an object required error at d2("v" & cbnr).Remove (ss).
a is an Array.
Sub cb_pop2(cbnr As Integer)
Dim i, j As Integer
Dim d2 as object
Dim ss as string
Set d2 = CreateObject("Scripting.Dictionary")
d2("v" & cbnr) = a
For i = cbnr To 5
UserForm1.Controls("ComboBox" & i).Clear
For j = cbnr To i
ss = UserForm1.Controls("ComboBox" & j - 1).Value
d2("v" & cbnr).Remove (ss)
Next j
UserForm1.Controls("ComboBox" & i).List = d2("v" & cbnr).keys
UserForm1.Controls("ComboBox" & i).ListIndex = 0
Next i
End Sub
This is an example of using dictionary in VBA
Sub TestDictionary()
Set dict = CreateObject("Scripting.Dictionary")
For x = 1 To 5
Key = "Start" & x
Value = 0 + x
If Not dict.Exists(Key) Then
dict.Add Key, Value
End If
Next x
For Each k In dict.keys
MsgBox (dict(k))
Next
If dict.Exists(Key) Then
dict.Remove Key
Else
'You can put here a code to show errors
End If
End Sub
I suggest you to use an If-Then to check "Key" before adding/removing so you will able to intercept errors depending by "wrong Key" or "not present Key"
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