How can I feed variable "CatchPhrase" with value from each cell from col S...?
I need to select all rows that contain value from each cell in col S.
Problem is that col S have 1996 diferent numbers, and col A have 628790 numbers..
Sub SelectManyRows()
Dim CatchPhrase As String
Dim WholeRange As String
Dim AnyCell As Object
Dim RowsToSelect As String
CatchPhrase = "10044"
'first undo any current highlighting
Selection.SpecialCells(xlCellTypeLastCell).Select
WholeRange = "A1:" & ActiveCell.Address
Range(WholeRange).Select
On Error Resume Next ' ignore errors
For Each AnyCell In Selection
If InStr(UCase$(AnyCell.Text), UCase$(CatchPhrase)) Then
If RowsToSelect <> "" Then
RowsToSelect = RowsToSelect & "," ' add group separator
End If
RowsToSelect = RowsToSelect & Trim$(Str$(AnyCell.Row)) & ":" & Trim$(Str$(AnyCell.Row))
End If
Next
On Error GoTo 0 ' clear error 'trap'
Range(RowsToSelect).Select
End Sub
Example of what I need:
Using the same approach as Is it possible to fill an array with row numbers which match a certain criteria without looping?
You can return an array of numbers from column A (I have used A1:A200 in this example) that match a list in S1:S9 as below
Sub GetEm()
Dim x
x = Filter(Application.Transpose(Application.Evaluate("=if(NOT(ISERROR(MATCH(A1:A200,$S$1:S9,0))),a1:a200,""x"")")), "x", False)
End Sub
The second sub does a direct selection of these cells
Sub GetEm2()
Dim x1
x1 = Join(Filter(Application.Transpose(Application.Evaluate("=if(NOT(ISERROR(MATCH(A1:A200,$S$1:S9,0))),""a""&row(a1:a200),""x"")")), "x", False), ",")
Application.Goto Range(x1)
End Sub
Consider:
Sub dural()
Dim rS As Range, wf As WorksheetFunction
Dim N As Long, aryS As Variant, rSelect As Range
Dim i As Long, v As Variant
'
' Make an array from column S
'
N = Cells(Rows.Count, "S").End(xlUp).Row
Set wf = Application.WorksheetFunction
Set rS = Range("S1:S" & N)
aryS = wf.Transpose(rS)
'
' Loop down column A looking for matches
'
Set rSelect = Nothing
N = Cells(Rows.Count, "A").End(xlUp).Row
For i = 1 To N
v = Cells(i, 1).Value
If v = Filter(aryS, v)(0) Then
If rSelect Is Nothing Then
Set rSelect = Cells(i, 1)
Else
Set rSelect = Union(Cells(i, 1), rSelect)
End If
End If
Next i
'
' Select matching parts of column A
'
rSelect.Select
End Sub
Related
I have the following macro that I got from someone, and trying to modify it to suit my purpose.
I'm trying to alter this macro to find and highlight cells that have duplicate values within each cell,
for example, it should highlight B62 and B63 (green),
and color font red the duplicate values (i.e. B_HWY_1010 in B62, and B_HWY_1015 in B63)
Sub Dupes()
Dim d As Object
Dim a As Variant, itm As Variant
Dim i As Long, k As Long
Dim rng As Range
Dim bColoured As Boolean
Set d = CreateObject("Scripting.Dictionary")
Set rng = Range("B1", Range("B" & Rows.Count).End(xlUp))
a = rng.Value
For i = 1 To UBound(a)
For Each itm In Split(a(i, 1), ",")
d(itm) = d(itm) + 1
Next itm
Next i
Application.ScreenUpdating = False
For i = 1 To UBound(a)
k = 1
bColoured = False
For Each itm In Split(a(i, 1), ",")
If d(itm) > 1 Then
If Not bColoured Then
rng.Cells(i).Interior.Color = vbGreen
bColoured = True
End If
rng.Cells(i).Characters(k, Len(itm)).Font.Color = RGB(244, 78, 189)
End If
k = k + Len(itm) + 1
Next itm
Next i
Application.ScreenUpdating = True
End Sub
Any help or advise is appreciated.
The following will do that
Option Explicit
Public Sub Example()
Dim Cell As Range
For Each Cell In Range("A1:A10")
HighlightRepetitions Cell, ", "
Next Cell
End Sub
Private Sub HighlightRepetitions(ByVal Cell As Range, ByVal Delimiter As String)
If Cell.HasFormula Or Cell.HasArray Then Exit Sub ' don't run on formulas
Dim Dict As Object
Set Dict = CreateObject("Scripting.Dictionary")
Dim Data() As String
Data = Split(Cell.Value, Delimiter) ' split data in the cell by Delimiter
Dim StrLen As Long ' length of the string that was already processed
Dim i As Long
For i = LBound(Data) To UBound(Data) ' loop through all data items
Dim DataLen As Long
DataLen = Len(Data(i)) 'get length of current item
If Dict.Exists(Data(i)) Then
' item is a repetition: color it
Cell.Characters(StrLen + 1, DataLen).Font.Color = vbRed
Cell.Interior.Color = vbGreen
Else
' item is no repetition: add it to the dictionary
Dict.Add Data(i), Data(i)
End If
StrLen = StrLen + DataLen + Len(Delimiter) ' calculate the length of the processed string and add length of the delimiter
Next i
End Sub
The following items would be colored:
You can turn ScreenUpdating off before looping in Sub Example() and turn on after the loop to stop it from flickering. Note this will not run on formuas, as parts of formula results cannot be colored. This can be prevented by using If Cell.HasFormula Or Cell.HasArray Then Exit Sub as first line.
Please, try the next code, too:
Sub findComaDelDuplicates()
Dim sh As Worksheet, arr, itm, arrInt, i As Long, rngS As Range, pos As Long
Dim arrDif As Long, j As Long, startPos As Long, arrPos, k As Long, mtch
Set sh = ActiveSheet
With sh.Range("B1", Range("B" & sh.rows.count).End(xlUp))
arr = .value 'put the range value in an array to make the iteration faster
.ClearFormats 'clear previous format
.Font.Color = vbBlack 'make the font color black
End With
For i = 1 To UBound(arr) 'iterate between the array elements:
arrInt = Split(arr(i, 1), ",") 'split the content by comma delimiter
ReDim arrPos(UBound(arrInt)) 'redim the array keeping elements already formatted
For Each itm In arrInt 'iterate between the comma separated elements
arrDif = UBound(arrInt) - 1 - UBound(Filter(arrInt, itm, False)) 'find how many times an element exists
If arrDif > 0 Then 'if more then an occurrence:
If rngS Is Nothing Then 'if range to be colored (at once) does not exist:
Set rngS = sh.Range("B" & i) 'it is crated
Else
Set rngS = Union(rngS, sh.Range("B" & i)) 'a union is made from the previous range and the new one
End If
mtch = Application.match(itm, arrPos, 0) 'check if the itm was already processed:
If IsError(mtch) Then 'if itm was not processed:
For j = 1 To arrDif + 1 'iterate for number of occurrences times
If j = 1 Then startPos = 1 Else: startPos = pos + 1 'first time, inStr starts from 1, then after the first occurrence
pos = InStr(startPos, sh.Range("B" & i).value, itm) 'find first character position for the itm to be colored
sh.Range("B" & i).Characters(pos, Len(itm)).Font.Color = vbRed 'color it
Next j
arrPos(k) = itm 'add the processed itm in the array
End If
End If
Next
Erase arrInt 'clear the array for the next cell value
Next i
If Not rngS Is Nothing Then rngS.Interior.Color = vbGreen 'color the interior cells of the built range
End Sub
Attention: The above code puts the range in an array to iterate much faster. But, if the range does not start form the first row, the cells to be processed must be obtained by adding to i the rows up to the first of the range. The code can be adapted to make this correlation, but I am too lazy to do it now...:)
I am working with a schedule, that I have imported and formatted into my workbook.
I am wanting this to populate Phase in the upper listbox and then when a phase is selected the sub-task associated with those phases are displayed in the bottom listbox.
I want to use an array but I seem to be having problems when the columns are not next to each other or there are "gaps" with the blank cells.
My first attempt using assigning the Array to the currentregion worked but brought all columns and fields in. Listbox1 should contain (ID, PHASE NAME, DURATION, START DATE, FINISH DATE) List box 2 should when a Phase is selected contain the subtasks if any from the column to the right, listed before the next next Phase name. (ID, SUB-TASK NAME, DURATION, START DATE, FINISH DATE)
(See picture)
I have code but its more me trouble-shooting than an actual semi working script.
Dim shT As Worksheet
Dim schnumrng1 As Range
Dim schnumrng2 As Range
Dim schnumrng3 As Range
Dim schnumrng4 As Range
Dim schnumrng5 As Range
Dim schpersonrng As Range
Dim schphaserng As Range
Dim schlistrng As Range
Dim maxschnum
Dim schstatus
Dim schperson
Dim schlistnum
Dim Ar() As String
Dim i As Long
Dim j As Long
Dim rng As Range
Dim cl As Range
Dim lc
'allowevents = True
''Set Screen parameters
'Application.ScreenUpdating = False
'Application.EnableEvents = False
'
Worksheets("Schedule").Visible = True
ThisWorkbook.Worksheets("Schedule").Activate
'
Set shT = Worksheets("Schedule")
maxschnum = shT.Cells(shT.Rows.Count, "A").End(xlUp).Row
Set schnumrng = Range("B5", "B" & maxschnum)
'Set Ranges for the list box
Set schnumrng1 = Range("A5", "A" & maxschnum)
Set schnumrng2 = Range("B5", "B" & maxschnum)
Set schnumrng3 = Range("D5", "D" & maxschnum)
Set schnumrng4 = Range("E5", "E" & maxschnum)
Set schnumrng5 = Range("F5", "F" & maxschnum)
'This is static and not moving to the next line in my for statement / switched to named ranges and errors
Set rng = schnumrng1, schnumrng2, schnumrng3, schnumrng4, schnumrng5
'Set rng = Range("A5,B5,D5,E5,F5")
i = 1
j = 1
For Each lc In schnumrng
If lc <> vbNullString Then
For Each cl In rng
ReDim Preserve Ar(1, 1 To i)
Ar(j, i) = cl.Value
i = i + 1
Next cl
Else
End If
j = j + 1
Next lc
With ScheduleForm.SchMainTasklt
.ColumnCount = i - 1
.ColumnWidths = "50;150;50;50;50"
.List = Ar
End With
My problem then is two fold, trying to use the dynamic ranges or another tool Index? collection? to populate the 1st list box. 2. How to deal with blanks and noncontiguous columns when data is not separated for organization purposes.
I don't know if I figured out your intentions well.
First, only the data in column b, not empty cells, is extracted from listbox1.
Second, when listbox1 is selected, data related to listbox2 is collected through the selected listbox value.
Module Code
Place this code in the module. This is because global variables must be used.
Public vDB As Variant
Public Dic As Object 'Dictionary
Sub test()
Dim shT As Worksheet
Dim maxschnum As Long
Dim Ar() As String
Dim i As Long
Dim j As Long
Dim vC() As Variant
Dim cnt As Integer, n As Integer
Dim c As Integer
Dim s As String, s2 As String
Worksheets("Schedule").Visible = True
ThisWorkbook.Worksheets("Schedule").Activate
'
Set Dic = CreateObject("Scripting.Dictionary") 'New Scripting.Dictionary
Set shT = Worksheets("Schedule")
maxschnum = shT.Cells(shT.Rows.Count, "A").End(xlUp).Row
With shT
vDB = .Range("a5", .Range("f" & maxschnum))
End With
'vC is data colum A,B,D,E,F
vC = Array(1, 2, 4, 5, 6)
s2 = vDB(2, 2)
For i = 2 To UBound(vDB, 1)
s = vDB(i, 2) 'column B
If s = "" Then
n = n + 1
Else
If Dic.Exists(s) Then
Else
If i > 2 Then
Dic(s2) = Dic(s2) & "," & n
End If
Dic.Add s, i
s2 = s
cnt = cnt + 1
ReDim Preserve Ar(1 To 5, 1 To cnt)
For c = 0 To UBound(vC)
Ar(c + 1, cnt) = vDB(i, vC(c))
Next c
End If
n = 0
End If
Next i
Dic(s2) = Dic(s2) & "," & n
' Records information about the data in a dictionary.
' Dic is "phase neme" is Key, Item is "2,4"
' example for KICkOFF
' dic key is "KICKOFF", Item is "5,4"
' 5 is KICOFF's row number in array vDB
' 4 is the number of blank cells related to kickoff.
With ScheduleForm.SchMainTasklt
.ColumnCount = 5
.ColumnWidths = "50;150;50;60;60"
.BoundColumn = 2
'.List = Ar
.Column = Ar 'In the state that the array has been converted to row column, you can use listbox.column.
End With
End Sub
Form Code
Private Sub UserForm_Initialize()
Call test
End Sub
Private Sub SchMainTasklt_Click()
Dim s As String, sItem As String
Dim arr As Variant, vC As Variant
Dim vR() As Variant
Dim st As Long, ed As Long
Dim iLast As Long, iFirst As Long
Dim i As Long, n As Integer
Dim j As Integer
vC = Array(1, 3, 4, 5, 6) 'data colums A,C,D,E,F
s = SchMainTasklt.Value
'MsgBox s
sItem = Dic(s)
arr = Split(sItem, ",")
st = Val(arr(0))
ed = Val(arr(1))
iFirst = st + 1
iLast = st + ed
If ed = 0 Then
MsgBox "no data!!"
Exit Sub
End If
For i = iFirst To iLast
n = n + 1
ReDim Preserve vR(1 To 5, 1 To n)
For j = 0 To UBound(vC)
vR(j + 1, n) = vDB(i, vC(j))
Next j
Next i
With ListBox2
.ColumnCount = 5
.ColumnWidths = "50;150;50;60;60"
.BoundColumn = 2
.Column = vR
End With
End Sub
Result Image
When you click the "KICKOFF" , Show kickoff related data in listbox2.
Given the following spreadsheet of data: https://ethercalc.org/q7n9zwbzym5y
I have the following code that will parse this and will derive a tree from the parent-child relationships in the sheet. Note that fact that every column occurs twice is because the first instance of the columns is for another type of data, I am only concerned with the populated columns. This is the desired output from the sheet above:
Code:
Sub performanceSheet(someParams)
' Write to "Performance" sheet
Dim w1 As Worksheet, w2 As Worksheet, wsSearch As Worksheet, wsData As Worksheet
Dim num_rows
Dim parent As Range, parentName As String
Dim parentRange As Range, childrenRange As Range
Dim childCount As Long
Dim p As Variant
Dim f1 As Range, f2 As Range
currRow = 8
Dim dict As Object
Set dict = CreateObject("Scripting.Dictionary")
Set w1 = wbk.Sheets("PositionsDB")
Set w2 = wbk.Sheets("Performance")
num_rows = w1.Cells(Rows.Count, 1).End(xlUp).row
'If there's no parentName column, we can't continue.
If w1.Rows(1).Find("portfolioName") Is Nothing Then Exit Sub
'find first instance
Set f1 = w1.Rows(1).Find("portfolioName", lookat:=xlWhole)
If Not f1 Is Nothing Then
'find second instance
Set f2 = f1.Offset(0, 1).Resize(1, w1.Columns.Count - f1.Column).Find("portfolioName", lookat:=xlWhole)
If Not f2 Is Nothing Then
'set range based on f2
Set parentRange = w1.Range(f2.Offset(1, 0), _
w1.Cells(Rows.Count, f2.Column).End(xlUp))
End If
End If
'If there's no Root level, how do we know where to start?
If parentRange.Find("Main") Is Nothing Then Exit Sub
For Each parent In parentRange
If Not dict.Exists(parent.Value) Then
childCount = Application.WorksheetFunction.CountIf(parentRange, parent.Value)
Set childrenRange = parent.Offset(, 2).Resize(childCount, 1)
dict.Add parent.Value, Application.Transpose(Application.Transpose(childrenRange.Value))
End If
Next
' Recursive method to traverse our dictionary, beginning at Root element.
Call PerformanceProcessItem("", "Main", dict, w2, 9)
wbk.Sheets("Performance").Columns("A:F").AutoFit
End Sub
Private Sub PerformanceProcessItem(parentName As String, name As String, dict As Object, ws As Worksheet, row_num As Long, Optional indent As Long = 0)
Dim output As String, v
Dim w2 As Worksheet
'Debug.Print WorksheetFunction.Rept(" ", indent) & name
'Debug.Print parentName & name
'write to sheet
ws.Cells(row_num, 3).Value = name
row_num = row_num + 1
If Not dict.Exists(name) Then
'we're at a terminal element, a child with no children.
Exit Sub
Else
For Each v In dict(name)
' ## RECURSION ##
Call PerformanceProcessItem(name, CStr(v), dict, ws, row_num, indent + 2)
Next
End If
End Sub
However, when creating this tree, it gets stuck on an infinite loop of India's, where after recognizing "Cash" as the terminal element of India, rather than exiting that subtree it will create another India and continue until overflow. Is there a logic error in my code? Hours of debugging hasn't worked for me and any input would be appreciated on where I have a flaw in my logic.
I am assuming that "Main" and "Cash" will always be there. If not then we will have to tweak the code little bit. I have commented the code so you may not have a problem understanding it. But if you do, simply ask. I quickly wrote this code so I am sure it can be optimized :)
Option Explicit
Dim sB As String
Dim tmpAr As Variant
Sub Sample()
Dim col As New Collection
Dim s As String
Dim ws As Worksheet
Dim lRow As Long, i As Long, j As Long
Dim itm As Variant, vTemp As Variant
Set ws = Sheet1 '<~~ Change this to the relevant sheet
With ws
'~~> Get Last Row of Col AA
lRow = .Range("AA" & .Rows.Count).End(xlUp).Row
'~~> Store Range AA:AC in an array
tmpAr = .Range("AA2:AC" & lRow).Value
End With
'~~> Create a unique collection of portfolioName
For i = LBound(tmpAr) To UBound(tmpAr)
If tmpAr(i, 1) = "Main" Then
On Error Resume Next
col.Add tmpAr(i, 3), CStr(tmpAr(i, 3))
On Error GoTo 0
End If
Next i
'~~> Sort the collection
For i = 1 To col.Count - 1
For j = i + 1 To col.Count
If col(i) > col(j) Then
vTemp = col(j)
col.Remove j
col.Add vTemp, vTemp, i
End If
Next j
Next i
s = "Main"
For Each itm In col
sB = vbTab & itm
s = s & vbNewLine & sB
sB = ""
GetParentChild itm, 2
If Trim(sB) <> "" Then _
s = s & vbNewLine & sB
Next itm
s = s & vbNewLine & vbTab & "Cash"
Debug.Print s
End Sub
Private Sub GetParentChild(strg As Variant, n As Integer)
Dim sTabs As String
Dim j As Long, k As Long
For k = 1 To n
sTabs = sTabs & vbTab
Next k
For j = LBound(tmpAr) To UBound(tmpAr)
If Trim(tmpAr(j, 1)) = Trim(strg) And Trim(tmpAr(j, 1)) <> "Cash" Then
sB = sB & sTabs & tmpAr(j, 3) & vbNewLine
GetParentChild tmpAr(j, 3), n + 1
End If
Next j
End Sub
This is what I got when I ran it on the data that you provided.
Problem :
Code returns 0 matches.
Code :
Sub searchNames()
Dim loc As String
Call location(loc)
Dim loadWb As Workbook
Dim loadWs As Worksheet
' ~~ Load file location
Set loadWb = Workbooks.Open(loc)
Set loadWs = loadWb.Sheets("Sheet1")
' ~~ Init rows in loaded excel
Dim lrow As Long
With loadWs
' ~~ Set range for lookup value
lrow = .Range("G" & .rows.Count).End(xlUp).Row
End With
' ~~ Loop to remove trailing spaces
Dim TrimCounter As String
Dim NewString As String
For ind = 2 To lrow
' ~~ Set rows for trim
TrimCounter = loadWs.Range("G" & ind).Value
NewString = Trim(TrimCounter)
' ~ Write trimmed values
loadWs.Range("G" & ind).Value = NewString
Next ind
' ~~ Set output worksheet
Dim ws As Worksheet
Set ws = ThisWorkbook.Sheets("ALL BRANDS")
Dim lrowWs As Long
With ws
lrowWs = .Range("D" & .rows.Count).End(xlUp).Row
End With
Dim counter As Long
Dim rows As Long
Dim nameCounter As String
counter = 0
' ~~ Get controlPointNumber in ALL BRANDS
For ind = 2 To lrowWs
' ~~ Set controlPointNumber
nameCounter = ws.Range("D" & ind).Value
' ~~ Start with row 2 in loaded Excel to omit header
For ind2 = 2 To lrow
' ~~ Check if the name matches in ALL BRANDS
If loadWs.Range("G" & ind2).Value = nameCounter Then
counter = counter + 1
End If
Next ind2
' ~~ Write the value in Worksheet 'ALL BRANDS' equal to the results
ws.Range("L" & ind).Value = counter
' ~~ Init counter to 0 and check other controlPointNumber
counter = 0
rows = rows + 1
Next ind
' ~~ Close workbook ~ Byeee
loadWb.Close False
MsgBox "Scan finished! Scanned " & rows & " rows"
End Sub
Screenshots :
Am I missing something? Any ideas?
EDIT:
Problem located. There are spaces in the values in COLUMN G
Change the part of the code like this:
For ind = 2 To lrowWs
Debug.Print lrowWs
nameCounter = ws.Range("D" & ind).value
Debug.Print nameCounter
For ind2 = 2 To lrow
If loadWs.Range("G" & ind2).value = nameCounter Then
Debug.Print loadWs.Range("G" & ind2).value
counter = counter + 1
End If
Next ind2
ws.Range("L" & ind).value = counter
Stop
counter = 0
rows = rows + 1
Next ind
Then, when you reach the stop, you should have 3 different values in the immediate window. Take a good look at them, analyze them and repair the whole code correspondingly.
Edit:
Probably the error comes from the idea, that you can use something like this:
Dim rows As Long
Thus, VBA does not know what you mean, when you say rows.Count. Long story short, change the Dim rows as Long to Dim lngRows as long and fix correspondingly everywhere.
I always worked with the .find Method. For me it's easier and if you combined it with a dictionary you can do the whole range and can be sure that no Value will be missing. The code will take the range with values from column A and will count how often the value appears in the range. Hope the code can help you.
Sub Makro1()
'Excel objects.
Dim wb As Workbook
Dim ws As Worksheet
Dim rngLockin As Range
Dim rngFind As Range
Dim idx As Integer
Dim idxRow As Integer
idxRow = 2
Dim strAddress As String
'Initialize the Excel objects.
Set wb = ThisWorkbook
Set ws = wb.Worksheets("Tabelle1")
Set dicSearch = CreateObject("Scripting.Dictionary")
LastRow = ws.UsedRange.Rows.Count
Set rngLockin = ws.Range("A2:A22").SpecialCells(xlCellTypeConstants)
For Each rngcell In rngLockin
'I Value is not in dic, insert it and start counting
If Not dicSearch.Exists(rngcell.Value) Then
dicSearch.Add rngcell.Value, ""
'Search the four columns for any constants.
'Retrieve all columns that contain X. If there is at least one, begin the DO/WHILE loop.
idx = 0
With rngLockin
Set rngFind = .Find(What:=rngcell.Value, LookIn:=xlValues)
If Not rngFind Is Nothing Then
strAddress = rngFind.Address
idx = idx + 1
rngFind.Select
'Unhide the column, and then find the next X.
Do
rngFind.EntireColumn.Hidden = False
Set rngFind = .FindNext(rngFind)
rngFind.Select
If Not rngFind Is Nothing And rngFind.Address <> strAddress Then idx = idx + 1
Loop While Not rngFind Is Nothing And rngFind.Address <> strAddress
End If
End With
Cells(idxRow, 3) = rngcell.Value
Cells(idxRow, 4).Value = idx
idxRow = idxRow + 1
End If
Next
End Sub
Fell free to ask if you have a question.
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.