always print out 6 digits following specific string - vba

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

Related

How to remove empty lines from cells in Excel (VBA)

Here's what I'm trying to achieve through all the cells in the worksheet containing a string, with limited success so far:
| EXAMPLE |
cell1_empty_line
cell1_text1
cell1_empty_line
+---------------------+
cell2_text1
cell2_emptyline
cell2_text2
+---------------------+
cell3_emptyline
cell3_emptyline
cell3_text1
+---------------------+
| EXPECTED RESULT |
cell1_text1
+---------------------+
cell2_text1
cell2_text2
+---------------------+
cell3_text1
+---------------------+
Any suggestion for such a macro?
Many thanks.
Use this macro to remove any empty lines inside all cells:
Sub TrimEmptyLines()
Dim cel As Range, s As String, len1 As Long, len2 As Long
For Each cel In ActiveSheet.UsedRange
If Not IsError(cel.Value2) Then
If InStr(1, cel.text, vbLf) > 0 Then
s = Trim(cel.Value2)
Do ' remove duplicate vbLf
len1 = Len(s)
s = Replace$(s, vbLf & vbLf, vbLf)
len2 = Len(s)
Loop Until len2 = len1
' remove vblf at beginning or at end
If Left$(s, 1) = vbLf Then s = Right$(s, Len(s) - 1)
If Right$(s, 1) = vbLf Then s = Left$(s, Len(s) - 1)
cel.value = Trim$(s)
End If
End If
Next
End Sub
This is general enough to handle any column of cells with any # of line feeds in each cell. It assumes all your values are in column "A" starting at row 1 of the active sheet:
Public Function RemoveDoubleLfs(str As String) As String
If InStr(str, vbLf & vbLf) > 0 Then
str = RemoveDoubleLfs(Replace(str, vbLf & vbLf, vbLf))
End If
RemoveDoubleLfs = str
End Function
Sub RemoveEmptyLines()
Dim i As Integer, lastRow As Integer
lastRow = ActiveSheet.Cells(Rows.Count, "A").End(xlUp).Row '
Dim val As String
For i = 1 To lastRow:
val = Cells(i, "A").Value
If InStr(1, val, vbLf) > 0 Then
val = RemoveDoubleLfs(val)
If Left(val, 1) = vbLf Then val = Right(val, Len(val) - 1)
If Right(val, 1) = vbLf Then val = Left(val, Len(val) - 1)
Cells(i, "A").Value = val
End If
Next
ActiveSheet.Rows.EntireRow.AutoFit
End Sub
The recursive replace function gets rid of double line feeds in the text of the cell. Once that's done there will be at most one VbLf at the beginning and end of the string. The last two if statements look for and remove the latter.
The autofit at the end is optional and is there purely to prettify the result; it just compacts the cells to their minimum height.
If you are working with just one cell and its blank lines within then one of these should work:
Cells.Replace what:=Chr(13), Replacement:="", LookAt:=xlPart
Cells.Replace what:=Chr(10), Replacement:="", LookAt:=xlPart
Before implementing this solution please set the values of the two variables at the top.
FirstDataColumn = 1
FirstDataRow = 2
This setting leaves starts with the first column but leaves out the first row which might contain column captions.
Sub RemoveBlanks()
Dim FirstDataColumn As Long, FirstDataRow As Long
Dim LastColumn As Long, LastRow As Long
Dim Tmp As Variant, Arr As Variant
Dim Counter As Integer
Dim C As Long, R As Long
FirstDataColumn = 1
FirstDataRow = 2
Application.ScreenUpdating = False
With ActiveSheet
With .UsedRange
LastColumn = .Columns.Count
LastRow = .Rows.Count
End With
For C = FirstDataColumn To LastColumn
ReDim Arr(LastRow, 0)
Counter = 0
For R = FirstDataRow To LastRow
Tmp = Trim(.Cells(R, C).Value)
If Len(Tmp) Then
Arr(Counter, 0) = Tmp
Counter = Counter + 1
End If
Next R
.Cells(FirstDataRow, C).Resize(LastRow, 1).Value = Arr
Next C
End With
Application.ScreenUpdating = True
End Sub

Error when trying to cycle through Autofiltered Cells using vba

I'm using the below code to remove invalid instances of text, in this case statements starting with colons. I know all of the steps I need to take, but I'm having issues after Autofitering. I've tried iterating through the visible cells using
for x=1 to currentFilter.rows.count
and
for each x in currentFilter.rows
But regardless of how I've tried I keep receiving some sort of error when trying to get rid of the the first character (the colon) by using (basic gist):
Cell Value = Right(Cell Value, Len(Cell Value) - InStr(Cell Value, ",", vbTextCompare))
My full code is as follows:
Sub PRTCheck()
'Column AN is Production Time & Column AP is Rush Time
Dim endRange As Integer, ShipandRush As Range, CommaColons As Collection, cell, i
endRange = ActiveSheet.Cells(Rows.count, "AN").End(xlUp).Row
Set ShipandRush = Union(ActiveSheet.Range("AN2:AN" & endRange), ActiveSheet.Range("AP2:AP" & endRange))
ShipandRush.NumberFormat = "#"
Set CommaColons = FindAllMatches(ShipandRush, ",:")
If Not CommaColons Is Nothing Then
Dim times() As String
For Each cell In CommaColons
times = Split(cell.Value, ",")
For i = LBound(times) To UBound(times)
If InStr(times(i), ":") = 1 Then times(i) = ""
Next
cell.Value = Join(times, ",")
Do While InStr(cell.Value, ",,") <> 0
cell.Value = Replace(cell.Value, ",,", ",", vbTextCompare)
Loop
If InStr(cell.Value, ",") = 1 Then
cell.Value = Right(cell.Value, Len(cell.Value) - 1)
End If
If InStr(Len(cell.Value), cell.Value, ",") = Len(cell.Value) Then
cell.Value = Left(cell.Value, Len(cell.Value) - 1)
End If
Next cell
End If
Set ShipandRush = ActiveSheet.Range("AN1:AN" & endRange)
Dim currentFilter As Range, r
ShipandRush.AutoFilter Field:=1, Criteria1:=":*" 'Starts with colon
Set currentFilter = ShipandRush.Offset(1).SpecialCells(xlCellTypeVisible)
If currentFilter.Rows.count > 0 Then
For r = 1 To currentFilter.Rows.count
'-------Error occurs on the next line-------
currentFilter.Cells(r).Value = Right(currentFilter.Cells(r).Value, Len(currentFilter.Cells(r).Value) - InStr(currentFilter.Cells(r).Value, ",", vbTextCompare))
Next
End If
ActiveSheet.AutoFilterMode = False
End Sub
'Custom find and replace that circumvents 255 character find limitation
Function FindAllMatches(rng As Range, txt As String) As Collection
Dim rv As New Collection, f As Range, addr As String, txtSrch As String
Dim IsLong As Boolean
IsLong = Len(txt) > 250
txtSrch = IIf(IsLong, Left(txt, 250), txt)
Set f = rng.Find(what:=txtSrch, lookat:=xlPart, LookIn:=xlValues, MatchCase:=False)
Do While Not f Is Nothing
If f.Address(False, False) = addr Then Exit Do
If Len(addr) = 0 Then addr = f.Address(False, False)
'check for the *full* value (case-insensitive)
If InStr(1, f.Value, txt, vbTextCompare) > 0 Then rv.Add f
Set f = rng.FindNext(After:=f)
Loop
Set FindAllMatches = rv
End Function
My Question:
What am I doing wrong? How can I iterate through each value in the visible cells and perform the formula I noted above successfully?
You are really only dealing with a single column but I will try to stick with your method of looping through the rows instead of the cells which in this instance are essentially the same thing (although Range.Rows is not the same thing as Range.Cells).
Discontiguous ranges need to be cycled through by their Range.Areas property first and then the Range.Rows property within each area.
dim a as long, r as long
with currentFilter
If .Rows.count > 0 Then
for a = 1 to .Areas.count
For r = 1 To .Areas(a).Rows.count
.Areas(a).Rows(r).Cells(1).Value = _
Right(.Areas(a).Rows(r).Cells(1).Value, _
Len(.Areas(a).Rows(r).Cells(1).Value) - _
InStr(1, .Areas(a).Rows(r).Cells(1).Value, ","))
Next r
Next a
End If
end with
It may be simpler to just use a For Each ... Next.
dim cfr as range
with currentFilter
for each cfr in .Cells
cfr = Right(cfr.Value, Len(cfr.Value) - InStr(1, cfr.Value, ","))
Next cfr
end with

Compare each name in one sheet with each string in another

There are two sheets named "Agents" and other one is "Owners" now the Agents sheets has about 37k rows in col "C" with Names like " CLARKE, DENISE JANE" All in one cell.
The other sheet "Owners" has very less about 1k rows of names in col "A" in format like this "Rafael" , "William" ,"Smith" ,etc all in different rows.
I am trying to compare each name in owners sheet with each string in agents sheet.
In this case. First Rafael will be compared with CLARKE then with DENISE then with JANE if match is found background color of Rafael
Now when I run this code it goes in maybe an infinite loop or something but the excel doesn't responds for a long time like 5 - 8 minutes it freezes. Even "Ctrl + Break" doesn't works I have to terminate it via task manager. I tried finding any flaws in this code but I wasn't able to do so.
Can any one help ?
Option Explicit
Sub Duplica()
Dim str1 As String
Dim str2 As String
Dim i, j, m, d, k, l As Long
Dim FinalRow, FinalRow1 As Long
Dim ws, wr As Worksheet
Dim pos As Integer
Dim Own
Dim Ago
Application.ScreenUpdating = False
Set ws = Sheets("Agents")
Set wr = Sheets("Owners")
FinalRow = ws.Range("C90000").End(xlUp).Row
FinalRow1 = wr.Range("A90000").End(xlUp).Row
For i = 1 To FinalRow
l = 0
pos = 0
With ws
str1 = .Cells(i, "C").Text
str1 = Replace(str1, "&", " ")
str1 = Replace(str1, ",", " ")
Ago = Split(str1, " ")
End With
For d = 1 To FinalRow1
With wr
str2 = .Cells(d, "A").Text
str2 = Replace(str2, "&", " ")
str2 = Replace(str2, ",", " ")
Own = Split(str2, " ")
End With
For m = LBound(Ago) To UBound(Ago)
For j = LBound(Own) To UBound(Own)
If Len(Own(j)) > 0 And Len(Ago(m)) > 0 Then 'if not a empty string
pos = InStr(1, Ago(m), Own(j), vbTextCompare) 'Find the owners name in Agents name
If Own(j) = Ago(m) Then 'If both are same
l = l + 1 'increment l
Else: End If
Else: End If
If l > 0 Or pos >= 1 Then
With wr
.Cells(d, "A").Interior.ColorIndex = 3
End With
l = 0
pos = 0
Else: End If
l = 0
pos = 0
Next j
Next m
Next d
Next i
End Sub
Try this out. It is a bit more straight forward. It is still going to take a few minutes as this is a lot of data to process.
The find option of LookAt:=xlPart gives us the search of any part of the field. Let me know if this works. The only issue is we may have an owner named bob and a agent name of Jimbob. That would be a hit. We can change it to look at each name if that is an issue.
Sub Duplica()
Dim wsAgents As Excel.Worksheet
Dim wsOwners As Excel.Worksheet
Dim lRow As Long
Dim Rng As Range
Dim lastRow As Long
Set wsAgents = ActiveWorkbook.Sheets("Agents")
Set wsOwners = ActiveWorkbook.Sheets("Owners")
'Get the last row that has an owner name
lastRow = wsOwners.Cells(wsOwners.Rows.count, "A").End(xlUp).Row
'Loop through the sheet with the owners
lRow = 1
Do While lRow <= lastRow
'Search for the owners name in the column on the agents sheet.
Set Rng = wsAgents.Range("C:C").Find(What:=UCase(wsOwners.Range("A" & lRow).Value), _
LookIn:=xlValues, _
LookAt:=xlPart, _
SearchOrder:=xlByRows, _
SearchDirection:=xlNext, _
MatchCase:=False)
'If we found the owner on the agent sheet color the owners name red.
If Not Rng Is Nothing Then
wsOwners.Range("A" & lRow).Interior.ColorIndex = 3
End If
Debug.Print str(lRow)
'Increment to the next row
lRow = lRow + 1
Loop
End Sub

VBA - optimizing code in functions for faster runtime

The code works very well but before I added sections (13) and (14), it ran in 6 minutes and now runs in 16 minutes. If there is a way to streamline this to cut down the runtime, that would be extraordinary.
Main part of code grabs values from under the header 'CUTTING TOOL' in various opening files in a designated folder. They are then printed to the workbook with code where all the information is printed to, StartSht, and the function alters the output information so that TL- has exactly 6 numbers following it and CT- has 4, plus an extra 2 if there is a "-" after the four numbers (ie CT-0081-01). If less than the specified length, 0s are added immediately after the "-". If greater than the specific length, 0s are deleted immediately after the "-".
Any suggestions on how to potentially streamline this code or general tips would be great. I have tried implementing the tips at this website but not much changed.
Main Code:
With WB
For Each ws In .Worksheets
'(3)
'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)
Else
'if no items are under the CUTTING TOOL header
StartSht.Cells(Rows.count, hc2.Column).End(xlUp).Offset(1, 0) = " "
End If
For k = 2 To StartSht.Range("C2").End(xlDown).Row
ret = ""
str = StartSht.Range("C" & k).Value
ret = ExtractNumberWithLeadingZeroes(str, "TL", 6)
If ret <> "" Then
StartSht.Range("C" & k).Value = "TL-" & ret
Else
'for CT numbers
ret = ExtractNumberWithLeadingZeroes(str, "CT", 4)
If ret <> "" Then
StartSht.Range("C" & k).Value = "CT-" & ret
End If
End If
Next k
...
...
...
Functions:
'(8)
'Get the Values from columns with specified headers
Function GetValues(ch As Range, Optional vSplit As Variant) As Scripting.Dictionary
Dim dict As Scripting.Dictionary
Dim dataRange As Range
Dim cell As Range
Dim theValue As String
Dim splitValues As Variant
Dim counter As Long
Set dict = New Scripting.Dictionary
Set dataRange = ch.Parent.Range(ch, ch.Parent.Cells(Rows.count, ch.Column).End(xlUp)).Cells
' If there are no values in this column then return an empty dictionary
' If there are no values in this column, the dataRange will start at the row
' *above* ch and end at ch
If (dataRange.Row = (ch.Row - 1)) And (dataRange.Rows.count = 2) And (Trim(ch.Value) = "") Then
GoTo Exit_Function
End If
For Each cell In dataRange.Cells
counter = counter + 1
theValue = Trim(cell.Value)
If Len(theValue) = 0 Then
theValue = " "
End If
'exclude any info after ";"
If Not IsMissing(vSplit) Then
splitValues = Split(theValue, ";")
theValue = splitValues(0)
End If
'exclude any info after ","
If Not IsMissing(vSplit) Then
splitValues = Split(theValue, ",")
theValue = splitValues(0)
End If
If Not dict.exists(theValue) Then
dict.Add counter, theValue
End If
Next cell
Exit_Function:
Set GetValues = dict
End Function
'(9)
'find a header on a row: returns Nothing if not found
Function HeaderCell(rng As Range, sHeader As String) As Range
Dim rv As Range, c As Range
For Each c In rng.Parent.Range(rng, rng.Parent.Cells(rng.Row, Columns.count).End(xlToLeft)).Cells
'copy cell value if it contains some string "holder" or "cutting tool"
If Trim(c.Value) = sHeader Then
'If InStr(c.Value, sHeader) <> 0 Then
Set rv = c
Exit For
End If
Next c
Set HeaderCell = rv
End Function
'(10)
'gets the last row in designated column
Function GetLastRowInColumn(theWorksheet As Worksheet, col As String)
With theWorksheet
GetLastRowInColumn = .Range(col & .Rows.count).End(xlUp).Row
End With
End Function
'(11)
'gets the last row in designated sheet
Function GetLastRowInSheet(theWorksheet As Worksheet)
Dim ret
With theWorksheet
If Application.WorksheetFunction.CountA(.Cells) <> 0 Then
ret = .Cells.Find(What:="*", _
After:=.Range("A1"), _
LookAt:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Row
Else
ret = 1
End If
End With
GetLastRowInSheet = ret
End Function
'(12)
'get the file name without the extension
Function GetFilenameWithoutExtension(ByVal FileName)
Dim Result, i
Result = FileName
i = InStrRev(FileName, ".")
If (i > 0) Then
Result = Mid(FileName, 1, i - 1)
End If
GetFilenameWithoutExtension = Result
End Function
'(13)
Public Function ExtractNumberWithLeadingZeroes(ByRef theWholeText As String, ByRef idText As String, ByRef numCharsRequired As Integer) As String
' Finds the first entry of idText, TL/CT, in theWholeText
' Returns the first number found after idText formatted with leading zeroes
Dim returnValue As String
Dim extraValue As String
Dim tmpText As String
Dim firstPosn As Integer
Dim secondPosn As Integer
Dim ctNumberPosn As Integer
returnValue = ""
firstPosn = InStr(1, theWholeText, idText)
If firstPosn > 0 Then
' remove any text before first idText, also remove the first idText
tmpText = Mid(theWholeText, firstPosn + Len(idText))
'if more than one idText value, delete everything after (and including) the second idText
secondPosn = InStr(1, tmpText, idText)
If secondPosn > 0 Then
tmpText = Mid(tmpText, 1, secondPosn)
End If
returnValue = ExtractTheFirstNumericValues(tmpText, 1)
If idText = "CT" Then
ctNumberPosn = InStr(1, tmpText, returnValue)
' Is the next char a dash? If so, must include more numbers
If Mid(tmpText, ctNumberPosn + Len(returnValue), 1) = "-" Then
' There are some more numbers, after the dash, to extract
extraValue = ExtractTheFirstNumericValues(tmpText, ctNumberPosn + Len(returnValue))
End If
End If
'force to numCharsRequired numbers if too short; add 0s immediately after idText
'force to numCharsRequired numbers if too long; eliminate 0s immediately after idText
' The CLng gets rid of leading zeroes and the Format$ adds any required up to numCharsRequired chars
If returnValue <> "" Then
returnValue = Format$(CLng(returnValue), String(numCharsRequired, "0"))
If extraValue <> "" Then
returnValue = returnValue & "-" & extraValue
End If
End If
End If
ExtractNumberWithLeadingZeroes = returnValue
End Function
'(14)
Private Function ExtractTheFirstNumericValues(ByRef theText As String, ByRef theStartingPosition As Integer) As String
Dim i As Integer
Dim j As Integer
Dim tmpText As String
Dim thisChar As String
' Find first number
For i = theStartingPosition To Len(theText)
If IsNumeric(Mid(theText, i, 1)) Then
tmpText = Mid(theText, i)
Exit For
End If
Next i
' Find where the numbers end
For j = 1 To Len(tmpText)
thisChar = Mid(tmpText, j, 1)
If Not IsNumeric(thisChar) Then
tmpText = Mid(tmpText, 1, j - 1)
Exit For
End If
Next j
ExtractTheFirstNumericValues = tmpText
End Function
have you put in break point to see which parts are taking the time ? For example is the For loop in the first part taking very much time ? The easiest way i can see you could speed things up is any time you do a Loop, For Each Cell instead set a variable equal to that range and loop through the variable. This can insanely increase speed especially if your touch a lot of cells. In my experience basically anything to do with cells is the slowest thing in excel. I often convert everything to variables, do all my work, then drop it back down when i am done. I have cut things for 2 hours to 2 minutes doing this.
Make it faster?
A large time saver was moving the section of code that the two functions are called from outside of the looping through files. That way, it would not stop after every file to fix it but rather fix all of the final output at the end. Cut the runtime in half!

Trying to extract data from curly braces but not working

I need to sync up the values in the curly braces {} found in column C and put them against the user id in column F as seen below.
E.g. on the Emails sheet
becomes this on a new sheet
Sub CopyConditional()
Dim wshS As Worksheet
Dim WhichName As String
Set wshS = ActiveWorkbook.Sheets("Emails")
WhichName = "NewSheet"
Const NameCol = "C"
Const FirstRow = 1
Dim LastRow As Long
Dim SrcRow As Long
Dim TrgRow As Long
Dim wshT As Worksheet
Dim cpt As String
Dim user As String
Dim computers() As String
Dim computer As String
On Error Resume Next
Set wshT = Worksheets(WhichName)
If wshT Is Nothing Then
Set wshT = Worksheets.Add(After:=wshS)
wshT.Name = WhichName
End If
On Error GoTo 0
If wshT.Cells(1, NameCol).value = "" Then
TrgRow = 1
Else
TrgRow = wshT.Cells(wshT.Rows.Count, NameCol).End(xlUp).Row + 1
End If
LastRow = wshS.Cells(wshS.Rows.Count, NameCol).End(xlUp).Row
For SrcRow = FirstRow To LastRow
cpt = wshS.Range("C" & SrcRow).value
user = wshS.Range("F" & SrcRow).value
If InStr(cpt, ":") Then
cpt = Mid(cpt, InStr(1, cpt, ":") + 1, Len(cpt))
End If
If InStr(cpt, ";") Then
computers = Split(cpt, ";")
For i = 0 To UBound(computers)
If computers(i) <> "" Then
wshT.Range("A" & TrgRow).value = user
wshT.Range("B" & TrgRow).value = Mid(Left(computers(i), Len(computers(i)) - 1), 2)
TrgRow = TrgRow + 1
End If
Next
Else
computer = cpt
If computer <> "" Then
wshT.Range("A" & TrgRow).value = user
wshT.Range("B" & TrgRow).value = Mid(Left(computer, Len(computer) - 1), 2)
TrgRow = TrgRow + 1
End If
End If
Next SrcRow
End Sub
I managed to resolve it with the above code but there are 3 niggling issues:
1) The first curly brace is always copied, how do I omit this so something like {Computer1 looks like Computer 1
2) Where there are two computers in a row, then the output looks something like this:
when it should really be split into two different rows i.e.
User 1 | Computer 1
User 1 | Computer 2
3) If there is text after the last curly brace with text in it e.g. {Computer1};{Computer2};Request submitted then that text is added as a new row, I don't want this, I want it to be omitted e.g.
should just be:
User 1 | Computer 1
User 1 | Computer 2
How do I go about rectifying these issues?
Try this:
Sub Collapse()
Dim uRng As Range, cel As Range
Dim comps As Variant, comp As Variant, r As Variant, v As Variant
Dim d As Dictionary '~~> Early bind, for Late bind use commented line
'Dim d As Object
Dim a As String
With Sheet1 '~~> Sheet that contains your data
Set uRng = .Range("F1", .Range("F" & .Rows.Count).End(xlUp))
End With
Set d = CreateObject("Scripting.Dictionary")
With d
For Each cel In uRng
a = Replace(cel.Offset(0, -3), "{", "}")
comps = Split(a, "}")
Debug.Print UBound(comps)
For Each comp In comps
If InStr(comp, "Computer") <> 0 _
And Len(Trim(comp)) <= 10 Then '~~> I assumed max Comp# is 99
If Not .Exists(cel) Then
.Add cel, comp
Else
If IsArray(.Item(cel)) Then
r = .Item(cel)
ReDim Preserve r(UBound(r) + 1)
r(UBound(r)) = comp
.Item(cel) = r
Else
r = Array(.Item(cel), comp)
.Item(cel) = r
End If
End If
End If
Next
Next
End With
For Each v In d.Keys
With Sheet2 '~~> sheet you want to write your data to
If IsArray(d.Item(v)) Then
.Range("A" & .Rows.Count).End(xlUp).Offset(1, 0) _
.Resize(UBound(d.Item(v)) + 1) = v
.Range("B" & .Rows.Count).End(xlUp).Offset(1, 0) _
.Resize(UBound(d.Item(v)) + 1) = Application.Transpose(d.Item(v))
Else
.Range("A" & .Rows.Count).End(xlUp).Offset(1, 0) = v
.Range("B" & .Rows.Count).End(xlUp).Offset(1, 0) = d.Item(v)
End If
End With
Next
Set d = Nothing
End Sub
Above code uses Replace and Split Function to pass your string to array.
a = Replace(cel.Offset(0, -3), "{", "}") '~~> standardize delimiter
comps = Split(a, "}") '~~> split using standard delimiter
Then information are passed to dictionary object using User as key and computers as items.
We filter the items passed to dictionary using Instr and Len Function
If InStr(comp, "Computer") <> 0 _
And Len(Trim(comp)) <= 10 Then
As I've commented, I assumed your max computer number is 99.
Else change 10 to whatever length you need to check.
Finally we return the dictionary information to the target worksheet.
Note: You need to add reference to Microsoft Scripting Runtime if you prefer early bind
Result: I tried it on a small sample data patterned on how I see it in you SS.
So assuming you have this data in Sheet1:
Will output data in Sheet2 like this:
I use a custom parse function for this type of operation:
Sub CopyConditional()
' some detail left out
Dim iRow&, Usern$, Computer$, Computers$
For iRow = ' firstrow To lastrow
Usern = Sheets("Emails").Cells(iRow, "F")
Computers = Sheets("Emails").Cells(iRow, "C")
Do
Computer = zParse(Computers) ' gets one computer
If Computer = "" Then Exit Do
' Store Computer and Usern
Loop
Next iRow
End Sub
Function zParse$(Haystack$) ' find all {..}
Static iPosL& '
Dim iPosR&
If iPosL = 0 Then iPosL = 1
iPosL = InStr(iPosL, Haystack, "{") ' Left
If iPosL = 0 Then Exit Function ' no more
iPosR = InStr(iPosL, Haystack, "}") ' Right
If iPosR = 0 Then MsgBox "No matching }": Stop
zParse = Mid$(Haystack, iPosL + 1, iPosR - iPosL - 1)
iPosL = iPosR
End Function
1) Use the Mid function to drop the first character:
str = "{Computer1"
str = Mid(str,2)
now str = "Computer1"
2) You can use the Split function to separate these out and combine with the Mid function above
str = "{Computer1}{Computer2}"
splt = Split(str,"}")
for a = 0 to Ubound(splt)
result = Mid(splt(a),2)
next a
3) Add a conditional statement to the above loop
str = "{Computer1}{Computer2}"
splt = Split(str,"}")
for a = 0 to Ubound(splt)
if Left(splt(a),1) = "{" then result = Mid(splt(a),2)
next a
Use this loop and send each result to the desired cell (in the for-next loop) and you should be good to go.