I am working with a large data file. B column of the excel sheet contains files names. However during download 2 characters get replaced (ä becomes +ñ and ö becomes +Â.) I need to be able to search with these file names so I need to reverse the names back to original.
Here is what I originally tried:
Private Sub scandit(n As Long)
Dim i As Long
For i = 2 To n
Dim a As String
Dim b As String
Dim c As String
Dim d As String
a = "+" & ChrW(194) ' +
b = ChrW(132) 'ä
c = "+" & ChrW(164) ' +n
d = ChrW(148) 'ö
If Not IsEmpty(Cells(i, 2).Value) Then
Cells(i, 2).Value = Replace(Cells(i, 2).Value, c, b)
Cells(i, 2).Value = Replace(Cells(i, 2).Value, a, d)
End If
Next i
End Sub
However this doesn't work. "+ñ" only gets removed but not replaced. Nothing happens to "+Â".
After some googling I found this:
Sub CommandButton1_Click()
Dim fnd As Range
With ActiveSheet
.Cells.Replace what:="+" & ChrW(194), replacement:=ChrW(132),
lookat:=xlPart
.Cells.Replace what:="+" & ChrW(164), replacement:=ChrW(148),
lookat:=xlPart
End With
End Sub
This has the exact same problem as my own code.
Example on how the replacement should work: sy+Âd+ñ -> syödä
It would be much appreciated if someone had some ideas on how to proceed here (note that I want to do the replacement only for cells in B column.)
I just changed the ChrW values and your code started working
Sub scandit()
Dim i As Long
For i = 2 To 5
Dim a As String
Dim b As String
Dim c As String
Dim d As String
a = "+" & ChrW(194) ' +
b = ChrW(228) 'ä
c = "+" & ChrW(241) ' +n
d = ChrW(246) 'ö
If Not IsEmpty(Cells(i, 2).Value) Then
Cells(i, 2).Value = Replace(Cells(i, 2).Value, c, b)
Cells(i, 2).Value = Replace(Cells(i, 2).Value, a, d)
End If
Next i
End Sub
Related
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 non-microsoft files that have look along the lines of:
>gibberish that changes
AAARRGGGHHHH
Now, I have a code to make a new .xlsx file out of this to split using Trying to convert files while keeping the old name.
However, I would like the "A2" cell contents to split with each indivual letter being assigned a cell and then have the former contents deleted. I don't mind if this ends up in A3 till AZ.
Thus, the above example I would like to transform to make it look like:
>gibberish that changes
A A A R R G G G H H H H
To clarify "Gibberish that changes" is not a constant it changes per file I have what is denoted here. Same holds true for the second line.
Based on Split cell string into individual cells
I tried this code:
Dim sVar1 as string
Dim sVar2 as string
I = InStr(1, strX, "A" & "R" & "G" & "H")
sVar1 = mid(strX, 1, I)
sVar2 = mid(strx,i+1)
However, this yields no results. It does not cause the Macro to fail (as I get no error message and the rest of the macro works (changing a file into another format and altering the name), but it doesn't do anything. I would like to use the string as the files constantly change in contents and order in cell A2.
I also have no true delimiter as things like ARRGHHHH is written as one word, is that causing the issue?
my 0.02 with Character object
Sub main()
With Range("A2")
For i = 1 To Len(.Value)
.Offset(, i) = .Characters(i, 1).Text
Next i
End With
End Sub
This will parse A2 into its characters and place the characters next to A2, each in its own cell:
Sub dural()
With Range("A2")
v = .Value
L = Len(v)
For i = 1 To L
.Offset(0, i).Value = Mid(v, i, 1)
Next i
End With
End Sub
EDIT#1:
This will handle both a range of input cells and the clearing of the original input data. Before:
The new macro:
Sub dural2()
Dim rng As Range, r As Range, v As Variant
Dim L As Long, i As Long
Set rng = Range("A2:A40")
For Each r In rng
v = r.Value
L = Len(v)
For i = 1 To L
r.Offset(0, i - 1).Value = Mid(v, i, 1)
Next i
Next r
End Sub
The result:
Would this be helpful at all?
Sub Test()
Dim i As Integer
Dim num As Integer
num = Len(Range("A1"))
For i = 1 To num
Debug.Print Mid(Range("A1"), i, 1)
Next
End Sub
Try this.
Sub dural()
With Range("A2")
v = .Value
L = Len(v)
For i = 0 To L - 1
If i = 0 Then
.Offset(0, i).Value = Left(v, 1)
Else
.Offset(0, i).Value = Mid(v, i, 1)
End If
Next i
End With
End Sub
Input
output
I have many strings with the name "TL-" followed by 6 digits (ie TL-000456, TL-000598). Sometimes it will print out having fewer than 6 digits (ie TL-09872, TL-345, TL-02).
I want my code to add a zero after the "TL-" until it contains 6 digits.
Start: Output:
TL-000456 -> TL-000456
TL-000598 -> TL-000598
TL-09872 -> TL-009872
TL-345 -> TL-000345
TL-02 -> TL-000002
If possible, I would like it to do this so that even if a space is included in the string (ie "TL - ", "TL -"), 6 digits would always be grabbed.
TL - 987 -> TL-000987
TL- 839 -> TL-000839
I have a function in my code which trims the "TL" values to get everything before a semicolon or comma so ideally the code would go in there. Thoughts?
CURRENT ATTEMPTS GIVEN COMMENTS:
Code gets values from under the header "CUTTING TOOL" in the ws (worksheet) and prints it to the StartSht (workbook with code)
(1) Returns error on Trim line saying in valid procedure or argument
With WB
For Each ws In .Worksheets
Dim sIn, sOut As String
'find CUTTING TOOL on the source sheet
If Not ws.Range("A1:M15").Find(What:="CUTTING TOOL", LookAt:=xlWhole, LookIn:=xlValues) Is Nothing Then
Set hc = ws.Range("A1:M15").Find(What:="CUTTING TOOL", LookAt:=xlWhole, LookIn:=xlValues)
Set dict = GetValues(hc.Offset(1, 0), "SplitMe")
If dict.count > 0 Then
'add the values to the workbook, column 3
Set d = StartSht.Cells(Rows.count, hc2.Column).End(xlUp).Offset(1, 0)
d.Resize(dict.count, 1).Value = Application.Transpose(dict.items)
'trim values **implement new code here**
With StartSht
Trim (Left(sIn, InStr(1, sIn, "-", vbTextCompare) - 1)) & "-" & Right("000000" & Trim(Right(sIn, Len(sIn) - InStr(1, sIn, "-", vbTextCompare))), 6)
End With
(2) Runs fully but does not change the values
With WB
For Each ws In .Worksheets
'find CUTTING TOOL on the source sheet
If Not ws.Range("A1:M15").Find(What:="CUTTING TOOL", LookAt:=xlWhole, LookIn:=xlValues) Is Nothing Then
Set hc = ws.Range("A1:M15").Find(What:="CUTTING TOOL", LookAt:=xlWhole, LookIn:=xlValues)
Set dict = GetValues(hc.Offset(1, 0), "SplitMe")
If dict.count > 0 Then
'add the values to the master list, column 3
Set d = StartSht.Cells(Rows.count, hc2.Column).End(xlUp).Offset(1, 0)
d.Resize(dict.count, 1).Value = Application.Transpose(dict.items)
Dim str As String, ret As String, tmp As String, j As Integer
With StartSht
For j = 1 To Len(str)
tmp = Mid(str, j, 1)
If IsNumeric(tmp) Then ret = ret + tmp
Next j
For j = Len(ret) + 1 To 6
ret = "0" & ret
Next
Debug.Print ret
End With
StartSht Excel document looks like this
A B C D
1 TDS HOLDER CUTTING TOOL File Name
2 TDS-1 H1 TL-000289 TDS-1.xlsx
3 TDS-2 H2 TL-000274 TDS-2.xlsx
4 TDS-3 H3 TL-0002 TDS-3.xlsx
5 TDS-4 H4 TL-0343 TDS-4.xlsx
after the "CUTTING TOOL" code I have below, it just looks like the output below the code because that is the first section I grab information for
CODE:
With WB
For Each ws In .Worksheets
'find CUTTING TOOL on the source sheet
If Not ws.Range("A1:M15").Find(What:="CUTTING TOOL", LookAt:=xlWhole, LookIn:=xlValues) Is Nothing Then
Set hc = ws.Range("A1:M15").Find(What:="CUTTING TOOL", LookAt:=xlWhole, LookIn:=xlValues)
Set dict = GetValues(hc.Offset(1, 0), "SplitMe")
If dict.count > 0 Then
'add the values to the master list, column 3
Set d = StartSht.Cells(Rows.count, hc2.Column).End(xlUp).Offset(1, 0)
d.Resize(dict.count, 1).Value = Application.Transpose(dict.items)
output of StartSht:
A B C D
1 TDS HOLDER CUTTING TOOL File Name
2 TL-000289
3 TL-000274
4 TL-0002
5 TL-0343
I want to add a line str = StartSht.Range(''set correct range here'') and then code to make the StartSht look like this
A B C D
1 TDS HOLDER CUTTING TOOL File Name
2 TL-000289
3 TL-000274
4 TL-000002
5 TL-000343
There is a way using an excel formula:
="TL-" & TEXT(TRIM(RIGHT(A1,LEN(A1)-FIND("-",A1,1))),"000000")
Expanding on Orphid's anwswer to include the 6 digits:
Sub Test()
Dim str as string, ret as string, tmp as string, i as integer, j as integer
for j = 2 to StartSht.Range("C2").End(xlDown).Row
ret = ""
str = StartSht.Range("C" & j).Value
for i = 1 to len(str)
tmp = mid(str, i, 1)
if IsNumeric(tmp) then ret = ret + tmp
next i
For i = Len(ret) + 1 To 6
ret = "0" & ret
Next
ret = "TL-" & ret
StartSht.Range("C" & j).Value = ret
next j
End Sub
This is going to write 'ret' in column B beside the original. The sheet you are working on needs to be active when this runs because as you can see I didn't specify which Sheet was to be used. You can do that yourself if it's necessary. I assumed it only needed to be done on 1 worksheet of 1 workbook for this. Let me know if i was wrong.
What have you tried so far? Do you have any code to show us?
This should be a starting point, you'll need to strip out spaces and loop through the whole file of course.
Public Sub PaddingTest()
Dim PaddingArray() As String
Dim PaddingVar As String
PaddingArray() = Split(Range("A1").Value, "-", 2, vbTextCompare)
PaddingVar = PaddingArray(1)
While Len(PaddingVar) < 6
PaddingVar = "0" & PaddingVar
Wend
Range("A2").Value = PaddingArray(0) & "-" & PaddingVar
End Sub
msdn.microsoft.com for usage of Split command
For extracting the number, it sounds like what you want is a regular expression similar to \d{1,6}. However, I've never really enjoyed working regex in VBA, so another way of extracting the number is:
Sub Test()
Dim str as string, ret as string, tmp as string, i as integer
str = "T- 087652"
for i = 1 to len(str) 'vba strings are 1-indexed
tmp = mid(str, i, 1) 'get the character at position i
if IsNumeric(tmp) then ret = ret + temp 'if numeric, add to the return value
next i
debug.print ret 'print the resulting number to the console. To convert to a number, simply assign to a variable typed as "long"
End Sub
What this does is a simple forward loop through the string, extracting every character which IsNumeric. It should ignore whitespace wherever it occurs in the string, but they shouldn't be more than one whole number per string.
For formatting the number, you probably just want to pad the string.
Here is a one liner. I am grabbing the data before and after the hypen, trimming them to remove spaces, and adding the hyphen and extra 0's.
Sub splitAddZeros()
Dim sIn, sOut As String
sIn = "TL - 987"
out = Trim(Left(sIn, InStr(1, sIn, "-", vbTextCompare) - 1)) & "-" & Right("000000" & Trim(Right(sIn, Len(sIn) - InStr(1, sIn, "-", vbTextCompare))), 6)
Debug.Print out
End Sub
Put this in a new module:
Option Explicit
Public Function getDigits(strInput As String) As String
Dim strOutput As String
Dim strCharacter As String
Dim i As Integer
strOutput = ""
For i = 1 To Len(strInput)
strCharacter = Mid(strInput, i, 1)
If strCharacter >= "0" And strCharacter <= "9" Then
strOutput = strOutput & strCharacter
End If
Next
getDigits = strOutput
End Function
Public Function addZeros(strInput As String) As String
Dim intCurrentLength As Integer
Dim strNumber As String
Dim i As Integer
strNumber = getDigits(strInput)
intCurrentLength = Len(strNumber)
If intCurrentLength < 6 Then
For i = 1 To 6 - intCurrentLength
strNumber = "0" & strNumber
Next i
End If
addZeros = "TL-" & strNumber
End Function
Then just run addZeros([your string here]) to convert to the required format.
(for user4888 in the comments of this question; an example of how to check whether 'TL' is in a string. This checks cells A1 to A10, and populates a 1 or a 0 in the corresponding cell in column B depending on whether there is a 'TL' in the cell)
Private Sub TLcheck()
Set wb = ThisWorkbook
Set ws = wb.ActiveSheet
For i = 1 To 10
ws.Cells(i, 2) = InStr(1, ws.Cells(i, 1), "TL")
Next i
End Sub
I need a vba code to concat range of cell values separated by two spaces into another cell.
For eg.
a1 a
a2 b
a3 c
a4 blank
a5 blank
a6 d
a7 e
a8 f
then value of cell B will be
b1 a,b,c
b2 d,e,f
This code concats single range and also concat space. I want space to be a delimiter and concat the range after space and loop through it.
Sub demo()
'i = 2
'if cells(i,2).value
Dim lastRow As Long
lastRow = ActiveSheet.Range("a" & Rows.Count).End(xlUp).Row
MsgBox (lastRow)
For i = 2 To lastRow
'Do Until Cells(i, 2).End(xlDown).Row = ""
If Cells(i, 3).Value = "" Then
Sheet2.Cells(i, 1).Value = Cells(i, 1) & " " & Cells(i, 2)
Else
Sheet2.Cells(i, 1).Value = Cells(i, 1) & " " & _
Cells(i, 2) & "(" & Cells(i, 3) & ")"
End If
' i = i + 1
Next i
End Sub
You could try this. This solves your first problem. I don't understand if you are presenting another problem in your second part, or trying to explain the first. Anyway, the sub treats a single blank as part of the range to process. Example output in the picture.
Just change the input range ("A1:A30" below). It puts the results in the column adjacent to the input data.
Public Sub spaced_out()
Dim rr, Ain As Range
Dim AB As Object
Dim rr_out_count As Integer
Set Ain = ActiveSheet.Range("A1:A30")
Set AB = CreateObject("scripting.dictionary")
For Each rr In Ain
If (rr.Value <> "") Then
AB.Add rr.Row(), rr.Value
ElseIf (rr.Value = "" And rr.Offset(1, 0).Value = "") Then
rr_out_count = rr_out_count + 1
Ain.Offset(0, 1).Cells(rr_out_count, 1).Value = Join(AB.items(), ",")
AB.RemoveAll
End If
Next
End Sub
I have an excel with some data separated by ";" in a cell.
I need to split that cell, and some subsequent one, so that splitted content will go each to a new line each.
Example:
Column f Column j Column k
a;b;c d;e;f g;h;i
Should become
a d g
b e h
c f i
This is what i have, but not working:
Sub tgr()
Dim rindex As Long
Dim saItem() As String
Dim sbItem() As String
Dim scItem() As String
For rindex = Cells(Rows.Count, "F").End(xlUp).Row To 1 Step -1
If InStr(Cells(rindex, "F").Value, ";") > 0 Then
saItem = Split(Cells(rindex, "F").Value, ";")
sbItem = Split(Cells(rindex, "J").Value, ";")
scItem = Split(Cells(rindex, "K").Value, ";")
Rows(rindex + 1 & ":" & rindex + UBound(saItem)).Insert
Cells(rindex, "F").Resize(UBound(saItem) + 1).Value = WorksheetFunction.Transpose(saItem)
Cells(rindex, "J").Resize(UBound(sbItem) + 1).Value = WorksheetFunction.Transpose(sbItem)
Cells(rindex, "K").Resize(UBound(scItem) + 1).Value = WorksheetFunction.Transpose(scItem)
End If
Next rindex
End Sub
Thanks for your help
You are using the wrong array for Col K. I guess you copy pasted and forgot to change it? :)
Replace the line
Cells(rindex, "K").Resize(UBound(sbItem) + 1).Value = WorksheetFunction.Transpose(sbItem)
with
Cells(rindex, "K").Resize(UBound(scItem) + 1).Value = WorksheetFunction.Transpose(scItem)