How to get the value between two asterisk in excel?
for example:
I have these: TXI*GS*346.32*13*SP*ON*3***103634408RT0001
I only want to get the value 346.32
i these data like this for A1:A20 how can i replace them all using VBA?
Sub useSplit()
Dim s As String
s = "TXI*GS*346.32*13*SP*ON*3***103634408RT0001"
Dim a() As String
a = Split(s, "*")
Dim i As Long
For i = 0 To UBound(a)
Debug.Print a(i)
Next
End Sub
Sub extractFirstNumber()
Set objRegEx = CreateObject("vbscript.regexp")
' Match numbers of the form 123 or 123.45
objRegEx.Pattern = "\d+(\.\d*)?"
' Iterate over the first 20 rows in first column
For i = 1 To 20
Set objMatch = objRegEx.Execute(Cells(i, 1).Value)
If objMatch.Count = 1 Then
' If there is a match, replace the cell value
Cells(i, 1).Value = objMatch(0)
End If
Next i
End Sub
Edit
Sub extractFirstAndThirdNumber()
Set objRegEx = CreateObject("vbscript.regexp")
' Match numbers of the form 123 or 123.45 between asteriks
objRegEx.Pattern = "\*(\d+(\.\d*)?)"
objRegEx.Global = True
' Iterate over the first 20 rows in first column
For i = 1 To 20
Set objMatch = objRegEx.Execute(Cells(i, 1).Value)
If objMatch.Count >= 2 Then
' If there is a match, replace the cell value
'Cells(i, 1).Value = objMatch(0)
Cells(i, 3).Value = objMatch(0).SubMatches(0)
Cells(i, 4).Value = objMatch(2).SubMatches(0)
End If
Next i
End Sub
Related
My problem is simple for VBA pro. if you can help me to understand please.
I am trying to call a function which keep only caps in a cell and past the result in the next column by looping all the rows. Please take a look at the code below.
Thank you.
Option Explicit
Sub LLOP()
Dim i As Integer
i = 1
Do While Cells(i, 10).Value <> ""
Cells(i, 11).Value = Cells(i, 10).Value = ExtractCap
i = i + 1
Loop
End Sub
Option Explicit
Function ExtractCap(Txt As String) As String
Application.Volatile
Dim xRegEx As Object
Set xRegEx = CreateObject("VBSCRIPT.REGEXP")
xRegEx.Pattern = "[^A-Z]"
xRegEx.Global = True
ExtractCap = xRegEx.Replace(Txt, "")
Set xRegEx = Nothing
End Function
Try something like as follows. Notes to follow.
1) Extract cap requires an argument which is the string you want to replace. I have used the value in the adjacent column
2) Option Explicit should only occur once at the top of the module
3) As you are looping rows uses Long not Integer to avoid potential overflow
4) Comparison with vbNullString is faster than empty string literal ""
Edit:
5) See #Jeeped's comment re Static xRegEx As Object followed by if xregex is nothing then Set xRegEx = CreateObject("VBSCRIPT.REGEXP") which significantly improves performance when called in a loop as the regex object only gets created once
Option Explicit
Sub LLOP()
Dim i As Long
i = 1
With ThisWorkbook.Worksheets("Sheet1") 'change as appropriate
Do While .Cells(i, 10).Value <> vbNullString 'column J
.Cells(i, 11).Value = ExtractCap(.Cells(i, 10).Text) 'column K
i = i + 1
Loop
End With
End Sub
Public Function ExtractCap(Txt As String) As String
Application.Volatile
Dim xRegEx As Object
Set xRegEx = CreateObject("VBSCRIPT.REGEXP")
xRegEx.Pattern = "[^A-Z]"
xRegEx.Global = True
ExtractCap = xRegEx.Replace(Txt, vbNullString)
End Function
Assuming that you want to enter a custom =ExtractCap() formula in the 11. column, with a parameter of the 10. column, this is a possible solution:
Option Explicit
Sub LLOP()
Dim i As Long: i = 1
Do While Cells(i, 10).Value <> ""
Cells(i, 11).Formula = "=ExtractCap(""" & Cells(i, 10) & """)"
i = i + 1
Loop
End Sub
Function ExtractCap(Txt As String) As String
Application.Volatile
Static xRegEx As Object
If xRegEx Is Nothing Then Set xRegEx = CreateObject("VBSCRIPT.REGEXP")
xRegEx.Pattern = "[^A-Z]"
xRegEx.Global = True
ExtractCap = xRegEx.Replace(Txt, "")
End Function
The .Formula passes the function ExtractCap as a formula with its parameter of Cells(i, 10).
Try below alternative code. Your method is complicated and uses regular expressions (which is nice, but in your case, ineffective).
The code:
Option Explicit
Sub LLOP()
Dim i As Integer
i = 1
'indentation! in your original code, you didn't have proper indentation
'I know that VBA editor don't indent code automatically, but it's worth the effort
Do While Cells(i, 10).Value <> ""
' invalid syntax!
' first, this is kind of multiple assignment (I don't know what are you trying to do)
' secondly, you call your function without arguments
' Cells(i, 11).Value = Cells(i, 10).Value = ExtractCap
' I guess you wanted something like this
Cells(i, 11).Value = ExtractCap(Cells(i, 10).Value)
'or using my function:
Cells(i, 11).Value = SimpleExtractCap(Cells(i, 10).Value)
i = i + 1
Loop
End Sub
'THIS IS YOUR FUNCTION, which is complicated (unnecessarily)
Function ExtractCap(Txt As String) As String
Application.Volatile
Dim xRegEx As Object
Set xRegEx = CreateObject("VBSCRIPT.REGEXP")
xRegEx.Pattern = "[^A-Z]"
xRegEx.Global = True
ExtractCap = xRegEx.Replace(Txt, "")
Set xRegEx = Nothing
End Function
'this is my alternative to your function, which is very simple and basic
Function SimpleExtractCap(Txt As String) As String
SimpleExtractCap = ""
Dim i As Long, char As String
For i = 1 To Len(Txt)
char = Mid(Txt, i, 1)
'if we have upper-case letter, then append it to the result
If isLetter(char) And char = UCase(char) Then
SimpleExtractCap = SimpleExtractCap & char
End If
Next
End Function
Edit:
In order to check if given character is letter, you'll need additional function:
Function isLetter(letter As String) As Boolean
Dim upper As String
upper = UCase(letter)
isletter = Asc(upper) > 64 And Asc(upper) < 91
End Function
Now, I added this function to code, to check if character is letter.
The script fills an array from a sheet called "Tigers" with 6 strings. Then it is supposed to compare that array to a differnt sheet titled "Elephants" and tell me if it finds an exact match. The troublesome code is found at the Application.Match method
Any help understanding how to correctly script a match with multiple values would be appreciated.
Sub matchData()
Dim arrCompare(5) As Variant
Dim intRow As Integer
Dim varRes As Variant
Set sht = ActiveSheet
Set shtTigers = Worksheets("Tigers").Range("A2:A100")
Set shtElephants = Worksheets("Elephants").Range("A2:A100")
Sheets("Elephants").Activate
For intRow = 2 To 100
arrCompare(0) = Worksheets("Elephants").Cells(intRow, 1).Value
arrCompare(1) = Worksheets("Elephants").Cells(intRow, 2).Value
arrCompare(2) = Worksheets("Elephants").Cells(intRow, 4).Value
arrCompare(3) = Worksheets("Elephants").Cells(intRow, 5).Value
arrCompare(4) = Worksheets("Elephants").Cells(intRow, 7).Value
arrCompare(5) = Worksheets("Elephants").Cells(intRow, 9).Value
'compare all 6 strings in array against Elephant sheet rows for a match
varRes = Application.Match(arrCompare(), shtTigers, 0)
'also tried
'varRes = Application.Match(((arrCompare(0))*((arrCompare(1))*((arrCompare(2)) * ((arrCompare(3)) * ((arrCompare(4)) * ((arrCompare(5))*((arrCompare(6)),shtTigers, 0)
'messagebox just gives a Error 13 or 2042 for varRes
MsgBox ("varRes = " & varRes)
Next
End Sub
Match requires a single lookup value but you're trying to pass the whole array. Iterate one element at at time instead:
Dim counter as Integer
For x = 0 to 5
If Not IsError(Application.Match(arrCompare(x), shtTigers, 0)) Then
counter = counter + 1
End If
Next x
If counter = 6 Then Debug.Print "Matches found"
I'm an Excel VBA newbie and i'm trying to get the duplicates rows to appends to the first occurence of that row.
Per exemple we have the table here
I would like to format data as here
The logic goes like this. Whenever we detect that the last name and the birth date are the same for the current and following line that mean we have a dependant and we need to append the dependant's data to the "Main"
I have started writing code but i'm not able to detect the dependants properly.
Below is what i have. please consider that i'm a real noob and i'm trying hard.
Sub formatData()
Dim sh As Worksheet
Dim rw As Range
Dim RowCount As Integer
'This variable is checked to see if we have a first occurence of a line
Dim firstOccurence
'Initialise the variables for that will be used to match the data
Dim LocationName
Dim PlanCode
Dim LastName
Dim FirstName
Dim dependantFirstName
Dim dependantLastName
Dim dependantBirthdate
RowCount = 0
firstOccurence = True
'Check if the spreadsheet already exist if not create it.
For i = 1 To Worksheets.Count
If Worksheets(i).Name = "Benefits Census Formatted" Then
exists = True
End If
Next i
If Not exists Then
'Create a new spreadsheet to add the data to
Set ws = Sheets.Add
Sheets.Add.Name = "Benefits Census Formatted"
End If
'Set the ActiveSheet to the one containing the original data
Set sh = Sheets("BENEFIT Census")
With ActiveSheet
LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
For Each rw In sh.Rows
'If the data of one cell is empty EXIT THE LOOP
If sh.Cells(rw.Row, 1).Value = "" Then
Exit For
End If
If rw.Row > 1 Then
'Afffecting the variables to the next loop so we can compare the values
nextLocationName = sh.Cells(rw.Row + 1, 1).Value
nextPlanCode = sh.Cells(rw.Row + 1, 2).Value
nextLastName = sh.Cells(rw.Row + 1, 3).Value
nextFirstName = sh.Cells(rw.Row + 1, 4).Value
nextEmploymentDate = sh.Cells(rw.Row + 1, 5).Value
nextBirthDate = sh.Cells(rw.Row + 1, 6).Value
nextDependantFirstName = sh.Cells(rw.Row + 1, 25).Value
nextDependantLastName = sh.Cells(rw.Row + 1, 26).Value
nextDependantBirthdate = sh.Cells(rw.Row + 1, 27).Value
Debug.Print LastName & " - " & FirstName & " ::: " & nextLastName & " - " & nextFirstName & " : " & rw.Row & " : " & firstOccurence
'First time you pass through the loop write the whole lane
If firstOccurence = True Then
'Affecting the variables to the current loops values
LocationName = sh.Cells(rw.Row, 1).Value
PlanCode = sh.Cells(rw.Row, 2).Value
LastName = sh.Cells(rw.Row, 3).Value
FirstName = sh.Cells(rw.Row, 4).Value
dependantFirstName = sh.Cells(rw.Row, 25).Value
dependantLastName = sh.Cells(rw.Row, 26).Value
dependantBirthdate = sh.Cells(rw.Row, 27).Value
'Write the current line
sh.Rows(rw.Row).Copy
'We copy the value into another sheet
Set ns = Sheets("Benefits Census Formatted")
LastRow = ns.Cells(ns.Rows.Count, "A").End(xlUp).Row + 1
ns.Rows(LastRow).PasteSpecial xlPasteValues
firstOccurence = False
Else
'We match the location with the plan code and the last name and first name of the user to find duplicates
If dependantFirstName <> nextDependantFirstName And PlanCode <> nextPlanCode And LastName <> nextLastName And FirstName <> nextFirstName Then
'We find a different dependant if the first name or the last name or the birthdate differs
'If Not (dependantFirstName <> nextDependantFirstName) Or Not (dependantLastName <> nextDependantLastName) Or Not (dependantBirthdate <> nextDependantBirthdate) Then
'We have a dependant Append it to the line
'append the user to the currentLine
'End If
Else
'If the dependantFirstName and the nextDependant First name doesn't match then on the next loop we print the full line
firstOccurence = True
End If
End If
RowCount = RowCount + 1
'End of if row > 2
End If
Next rw
End With
End Sub
This is the code I wrote for you. (Glad to see that so many others did, too. So you got a choice :-))
Sub TransscribeData()
' 25 Mar 2017
Dim WsS As Worksheet ' Source
Dim WsT As Worksheet ' Target
Dim TargetName As String
Dim LastRow As Long ' in WsS
Dim Rs As Long ' Source: row
Dim Rt As Long, Ct As Long ' Target: row / column
Dim Tmp As String
Dim Comp As String ' compare string
' Set Source sheet to the one containing the original data
Set WsS = Worksheets("BENEFIT Census")
LastRow = WsS.Cells(WsS.Rows.Count, NbcName).End(xlUp).Row
Application.ScreenUpdating = False
TargetName = "Benefits Census Formatted"
On Error Resume Next
Set WsT = Worksheets(TargetName) ' Set the Target sheet
If Err Then
' Create it if it doesn't exist
Set WsT = Worksheets.Add(After:=Worksheets(Worksheets.Count))
WsT.Name = TargetName
' insert the column captions here
End If
On Error GoTo 0
Rt = WsT.Cells(WsS.Rows.Count, NfdName).End(xlUp).Row
AddMain WsS, WsT, NbcFirstDataRow, Rt ' Rt is counting in the sub
For Rs = NbcFirstDataRow To LastRow - 1
With WsS.Rows(Rs)
Tmp = .Cells(NbcFname).Value & .Cells(NbcName).Value & .Cells(NbcDob).Value
End With
With WsS.Rows(Rs + 1)
Comp = .Cells(NbcFname).Value & .Cells(NbcName).Value & .Cells(NbcDob).Value
End With
If StrComp(Tmp, Comp, vbTextCompare) Then
AddMain WsS, WsT, Rs + 1, Rt
Else
Ct = WsT.Cells(Rt, WsT.Columns.Count).End(xlToLeft).Column
If Ct > NfdMain Then Ct = Ct + 1
With WsS.Rows(Rs + 1)
WsT.Cells(Rt, Ct + NfdRelate).Value = .Cells(NbcRelate).Value
WsT.Cells(Rt, Ct + NfdDepName).Value = .Cells(NbcDepName).Value
End With
End If
Next Rs
Application.ScreenUpdating = True
End Sub
The above code calls one Sub routine which you must add in the same code module which, by the way, should be a normal code module (by default "Module1" but you can rename it to whatever).
Private Sub AddMain(WsS As Worksheet, WsT As Worksheet, _
Rs As Long, Rt As Long)
' 25 Mar 2017
Rt = Rt + 1
With WsS.Rows(Rs)
WsT.Cells(Rt, NfdFname).Value = .Cells(NbcFname).Value
WsT.Cells(Rt, NfdName).Value = .Cells(NbcName).Value
WsT.Cells(Rt, NfdDob).Value = .Cells(NbcDob).Value
WsT.Cells(Rt, NfdMain).Value = "Main"
End With
End Sub
Observe that I inserted the word "Main" as hard text. You could also copy the content of the appropriate call in the Source sheet. This procedure only writes the first entry. Dependents are written by another code.
The entire code is controlled by two "enums", enumerations, one for each of the worksheets. Enums are the quickest way to assign names to numbers. Please paste these two enums at the top of your code sheet, before either of the procedures.
Private Enum Nbc ' worksheet Benefit Census
NbcFirstDataRow = 2 ' Adjust as required
NbcFname = 1 ' columns:
NbcName
NbcDob
NbcRelate
NbcDepName
End Enum
Private Enum Nfd ' worksheet Formatted Data
NfdFirstDataRow = 2 ' Adjust as required
NfdName = 1 ' columns:
NfdFname
NfdDob
NfdMain
NfdRelate = 0 ' Offset from NfdMain
NfdDepName
End Enum
Note that the rule of enums is that you can assign any integer to them. If you don't assign any number the value will be one higher than the previous. So, NfdMain = 4, followed by NfdRelate which has an assigned value of 0, followed by NfdDepName which has a value of 0 + 1 = 1.
The numbers in these enumerations are columns (and rows). You can control the entire output by adjusting these numbers. For example, "Main" is written into column NfdMain (=4 =D). Change the value to 5 and "Main" will appear in column 5 = E. No need to go rummaging in the code. Consider this a control panel.
In the formatted output I introduced a logic which is slightly different from yours. If you don't like it you can change it easily by modifying the enums. My logic has the family name as the main criterion in the first column (switched from the raw data). In column D I write "Main". But when there is a dependent I write the relationship in column D. Therefore only entries without any dependents will have "Main" in that column. For your first example, the formatted row will show Rasmond / Shawn / 01-01-1990 / Spouse / Jessica, Child 1 / Vanessa.
If you wish to keep the "Main and place "Spouse" in the next column, just set the enum NfdRelate = 1. With the "control panel" it's that simple.
I would use an approach using Dictionaries to collect and organize the data, and then output it. Judging both by your comments, and the code, there is a lot of stuff you haven't included. But the following code will take your original data, and output a table close to what you show -- some of the results ordering is different, but it is standardized (i.e. there is a relation listed with every dependent name.
In the dictionary, we use Last Name and Birthdate as the "key" so as to combine what you stated were the duplicates.
We define two Class objects
Dependent object which includes the Name and the Relation
Family object which includes the First and Last Names, and Birthdate as well as a collection (dictionary) of the dependent objects.
Once we have it organized, it is relatively simple to output it as we want.
For a discussion of Classes, you can do an Internet search. I would recommend Chip Pearson's Introduction to Classes
Be sure to read the notes in the code about renaming the class modules, and also setting a reference to Microsoft Scripting Runtime
Class1
Option Explicit
'Rename this module: cDependents
'set reference to Microsoft Scripting Runtime
Private pRelation As String
Private pDepName As String
Public Property Get Relation() As String
Relation = pRelation
End Property
Public Property Let Relation(Value As String)
pRelation = Value
End Property
Public Property Get DepName() As String
DepName = pDepName
End Property
Public Property Let DepName(Value As String)
pDepName = Value
End Property
Class2
Option Explicit
'rename this module: cFamily
'set reference to Microsoft Scripting Runtime
Private pFirstName As String
Private pLastName As String
Private pBirthdate As Date
Private pDependents As Dictionary
Public Property Get FirstName() As String
FirstName = pFirstName
End Property
Public Property Let FirstName(Value As String)
pFirstName = Value
End Property
Public Property Get LastName() As String
LastName = pLastName
End Property
Public Property Let LastName(Value As String)
pLastName = Value
End Property
Public Property Get Birthdate() As Date
Birthdate = pBirthdate
End Property
Public Property Let Birthdate(Value As Date)
pBirthdate = Value
End Property
Public Function ADDDependents(Typ, Nme)
Dim cD As New cDependents
Dim sKey As String
With cD
.DepName = Nme
.Relation = Typ
sKey = .Relation & Chr(1) & .DepName
End With
If Not pDependents.Exists(sKey) Then
pDependents.Add Key:=sKey, Item:=cD
End If
End Function
Public Property Get Dependents() As Dictionary
Set Dependents = pDependents
End Property
Private Sub Class_Initialize()
Set pDependents = New Dictionary
End Sub
Regular Module
Option Explicit
'set reference to Microsoft Scripting Runtime
Sub Family()
Dim wsSrc As Worksheet, wsRes As Worksheet, rRes As Range
Dim vSrc As Variant, vRes As Variant
Dim dF As Dictionary, cF As cFamily
Dim I As Long, J As Long
Dim sKey As String
Dim V As Variant, W As Variant
'Set source and results worksheets and results range
Set wsSrc = Worksheets("sheet1")
Set wsRes = Worksheets("sheet2")
Set rRes = wsRes.Cells(1, 1)
'read source data into array
With wsSrc
vSrc = .Range(.Cells(1, 1), .Cells(.Rows.Count, 1).End(xlUp)).Resize(columnsize:=5)
End With
'Collect and organize the family and dependent objects
Set dF = New Dictionary
For I = 2 To UBound(vSrc, 1)
Set cF = New cFamily
With cF
.FirstName = vSrc(I, 1)
.LastName = vSrc(I, 2)
.Birthdate = vSrc(I, 3)
.ADDDependents vSrc(I, 4), vSrc(I, 5)
sKey = .LastName & Chr(1) & .Birthdate
If Not dF.Exists(sKey) Then
dF.Add Key:=sKey, Item:=cF
Else
dF(sKey).ADDDependents vSrc(I, 4), vSrc(I, 5)
End If
End With
Next I
'Results will have two columns for each relation, including Main
' + three columns at the beginning
'get number of extra columns
Dim ColCount As Long
For Each V In dF
I = dF(V).Dependents.Count
ColCount = IIf(I > ColCount, I, ColCount)
Next V
ColCount = ColCount * 2 + 3
ReDim vRes(0 To dF.Count, 1 To ColCount)
vRes(0, 1) = "First Name"
vRes(0, 2) = "Last Name"
vRes(0, 3) = "Birthdate"
vRes(0, 4) = "Dependant"
vRes(0, 5) = "Dependant Name"
For J = 6 To UBound(vRes, 2) Step 2
vRes(0, J) = "Relation " & J - 5
vRes(0, J + 1) = "Dependant Name"
Next J
I = 0
For Each V In dF
I = I + 1
With dF(V)
vRes(I, 1) = .FirstName
vRes(I, 2) = .LastName
vRes(I, 3) = .Birthdate
J = 2
For Each W In .Dependents
J = J + 2
With .Dependents(W)
vRes(I, J) = .Relation
vRes(I, J + 1) = .DepName
End With
Next W
End With
Next V
Set rRes = rRes.Resize(rowsize:=UBound(vRes, 1) + 1, columnsize:=UBound(vRes, 2))
With rRes
.EntireColumn.Clear
.Value = vRes
With .Rows(1)
.Font.Bold = True
.HorizontalAlignment = xlCenter
End With
.EntireColumn.AutoFit
End With
End Sub
Source Data
Results
I had this project in Chemistry to supply a list of Compound elements
now I had found a website where it gives me a very long list of elements:
I had made this Code but it Doesn't Work
Sub move()
Dim list As Range
Set list = Range("A1:A2651")
For Each Row In list.Rows
If (Row.Font.Regular) Then
Row.Cells(1).Offset(-2, 1) = Row.Cells(1)
End If
Next Row
End Sub
Can you make it run for me? you can have your own algorithm ofc.
Assuming the list is constantly in the same format (i.e. Compound name, empty line, Compound Symbols, empty line) this quick code will work:
Sub move()
Dim x As Integer
x = 3
With ActiveSheet
Do Until x > 2651
.Cells(x - 2, 2).Value = .Cells(x, 1).Value
.Cells(x, 1).ClearContents
x = x + 4
Loop
End With
End Sub
After running you can then just sort columns A:B to remove the blanks.
After trying your original code I realised the problem was with the .regular property value. I've not seen .regular before, so swapped it to NOT .bold instead, and to ignore blank entries, then added the line for clearing the contents of the cell copied. This is most like the original code for reference:
Sub get_a_move_on()
Dim list As Range
Set list = ActiveSheet.Range("A1:A2561")
For Each Row In list.Rows
If Row.Font.Bold = False And Row.Value <> "" Then
Row.Cells(1).Offset(-2, 1) = Row.Cells(1)
Row.Cells(1).ClearContents
End If
Next Row
End Sub
P.S it's a list of compounds, not elements, there's only about 120 elements in the periodic table! ;)
Another way to retrieve the data you need via XHR and RegEx:
Sub GetChemicalCompoundsNames()
Dim sRespText As String
Dim aResult() As String
Dim i As Long
' retrieve HTML content
With CreateObject("MSXML2.XMLHTTP")
.Open "GET", "https://quizlet.com/18087424", False
.Send
sRespText = .responseText
End With
' regular expression for rows
With CreateObject("VBScript.RegExp")
.Global = True
.MultiLine = True
.IgnoreCase = True
.Pattern = "qWord[^>]*?>([\s\S]*?)<[\s\S]*?qDef[^>]*?>([\s\S]*?)<"
With .Execute(sRespText)
ReDim aResult(1 To .Count, 1 To 2)
For i = 1 To .Count
With .Item(i - 1)
aResult(i, 1) = .SubMatches(0)
aResult(i, 2) = .SubMatches(1)
End With
Next
End With
End With
' output to the 1st sheet
With Sheets(1)
.Cells.Delete
Output .Range("A1"), aResult
End With
End Sub
Sub Output(oDstRng As Range, aCells As Variant)
With oDstRng
.Parent.Select
With .Resize( _
UBound(aCells, 1) - LBound(aCells, 1) + 1, _
UBound(aCells, 2) - LBound(aCells, 2) + 1 _
)
.NumberFormat = "#"
.Value = aCells
.Columns.AutoFit
End With
End With
End Sub
Gives output (663 rows total):
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.