I found the concatenation/appending of two arrays to be a too cumbersome process for my example. But how to iterate through two arrays of sheets using For Each in a single block (how to shorten the following code)?
arr1 = Array("Sheet2", "Sheet3")
arr2 = Array("Sheet5", "Sheet6")
For Each sh In Sheets(arr1)
sh.Visible = True
Next sh
For Each sh In Sheets(arr2)
sh.Visible = True
Next sh
You can always combine your small arrays into a super array. For example:
Sub Klai()
arr1 = Array("Sheet2", "Sheet3")
arr2 = Array("Sheet5", "Sheet6")
arr3 = Array(arr1, arr2)
For Each a In arr3
For Each b In a
MsgBox Sheets(b).Name
Sheets(b).Visible = True
Next b
Next a
End Sub
Just to throw in yet another solution:
Option Explicit
Sub tmpSO()
Dim lngItem As Long
Dim strArray() As String
Dim strOneLongList As String
Dim arr1 As Variant, arr2 As Variant
'Your starting point
arr1 = Array("Sheet2", "Sheet3")
arr2 = Array("Sheet5", "Sheet6")
'Bring all of them together into one long string containing all sheets
strOneLongList = Join(arr1, "/") & "/" & Join(arr2, "/")
MsgBox "This is what strOneLongList currently looks like:" & Chr(10) & Chr(10) & strOneLongList
'Convert the list into a string array with four elements
strArray = Split(Join(arr1, "/") & "/" & Join(arr2, "/"), "/")
For lngItem = 0 To UBound(strArray)
ThisWorkbook.Worksheets(strArray(lngItem)).Visible = True
Next lngItem
End Sub
Explanations:
The Join functions brings all elements of an array together into one long string.
The Split function is very similar to the array function you originally used. Yet, array requires that you list the items in separate strings delimited by commas. Split expects one long string in which one character is chosen to separate all elements.
Caution: Choose the character wisely you are using in a split list to separate all elements in that list and make sure that this character can never be found in any element of the list. I chose the / character because it cannot be used in a name for a sheet. Alternative characters could be \ or * or something very exotic like ChrW(12484).
It is certainly not as simplistic (and thereby possibly "visually appealing") as the other solution provided by #Garys-Student. Yet, this solution avoids the Arrays function and thereby we can bypass the variables of type variant. The same applies to the For Each... loop. It requires also variables of type variant or object. So, I replaced this one too with a For ... Next loop.
I am not sure if I'd use this construction or the other solution. Maybe this answer is better in terms of speed and overhead. Yet, the other solution is certainly faster coded and easier to read. Is that really worth the potential benefit?
Update:
In short, the following sub is a re-write of your original post and does exactly the same. Yet, it does not make use of variant variables (which reduces overhead and is therefore favorable).
Dim lngItem As Long
Dim strArray() As String
strArray = Split("Sheet2/Sheet3/Sheet5/Sheet6", "/")
For lngItem = LBound(strArray) To UBound(strArray)
ThisWorkbook.Worksheets(strArray(lngItem)).Visible = True
Next lngItem
Related
I have a worksheet that contains information on projects. The worksheet contains a column which contains risks for each project. There is a one-to-many relationship between a project and its risks.
Currently the risks for a projects are added to single cell and separated by a line break. I need to add sequential identifiers at the start of each risk. So for example inside a particular cell it should look like this. The sequential number should be bold if at all possible.
1).**Risk 1
2).**Risk 2
3).**Risk 3
etc.
Any suggestions on how to tackle this would be appreciated.
Here's how I'd approach it via UDF:
' Reformats a list from a simple delimitation to a numbered list
' Accepts arrays of strings for inList (allowing array formulas)
' numFormat is a standard Excel-style format string (default "0. ")
' inDelimiter is the delimiter in the input list
' outDelimiter is the delimiter for the output list
Public Function TO_NUMBERED_LIST(inList As Variant, Optional numFormat As Variant, _
Optional inDelimiter As Variant, Optional outDelimiter As Variant) As Variant
Dim i As Integer, j As Integer
' Set default parameters
If IsMissing(numFormat) Then numFormat = "0). "
If IsMissing(inDelimiter) Then inDelimiter = vbNewLine
If IsMissing(outDelimiter) Then outDelimiter = inDelimiter
If IsArray(inList) Then ' Must loop through each entry if using as an array formula
Dim outList() As Variant
ReDim outList(0 To (UBound(inList) - LBound(inList)), 1 To 1)
j = 0
For i = LBound(inList) To UBound(inList)
If IsError(inList(i, 1)) Then
outList(j, 1) = inList(i, 1)
Else
outList(j, 1) = MakeNumbered(CStr(inList(i, 1)), CStr(numFormat), CStr(inDelimiter), CStr(outDelimiter))
End If
j = j + 1
Next
TO_NUMBERED_LIST = outList
Else
TO_NUMBERED_LIST = MakeNumbered(CStr(inList), CStr(numFormat), CStr(inDelimiter), CStr(outDelimiter))
End If
End Function
' Helper function to do the actual work of splitting lists, numbering them, and recombining them
Private Function MakeNumbered(inList As String, Optional numFormat As String, _
Optional inDelimiter As String, Optional outDelimiter As String) As String
Dim i As Integer
Dim tokenArr() As String
tokenArr = Split(inList, inDelimiter)
For i = 0 To UBound(tokenArr)
tokenArr(i) = Format(i + 1, numFormat) & tokenArr(i)
Next
MakeNumbered = Join(tokenArr, outDelimiter)
End Function
I leverage some knowledge from your previous thread, like the fact that the input might be an array (and the whole function might be used in an array formula) but will only ever be 1-dimensional.
I've made this pretty general for reformatting. It can take in lists with any input delimiter (in your case, a newline) and output using any desired delimiter (in your case, still a newline). The numFormat parameter acts using the Format function and supports formats like you would commonly see in Excel. Check the documentation if you need help there.
Default parameters have already been tweaked for your example - newline as delimiter(s) and "0). " as numbering format.
You can use the Split function on each cell value to create an array of risks and then prefix each risk with the sequence id. Then you can use the Join function to put the array back into a single value to update the cell with.
Depending on how the newlines got into the cell you might need to use vbCrLf, or vbNewLine instead of vbLf in the following example code:
Option Explicit
Sub AddRiskSequence()
Dim rngRisks As Range
Dim rngCell As Range
Dim varRisks As Variant
Dim lngIndex As Long
'set range with risk values
Set rngRisks = Sheet2.Range("B2:B4")
'iterate cells in risk column
For Each rngCell In rngRisks
'split cell contents by line feed into array
varRisks = VBA.Split(rngCell.Value, vbLf)
'iterate array and add sequence ids
For lngIndex = 0 To UBound(varRisks)
varRisks(lngIndex) = VBA.CStr(lngIndex + 1) & ") " & varRisks(lngIndex)
Next lngIndex
'rejoin array and update cell value
rngCell.Value = VBA.Join(varRisks, vbLf)
Next rngCell
End Sub
Before:
After:
I wrote a sub to remove the blank entries in a row without shifting the cells around but it seems unnecessarily clunky and I'd like to get some advice on how to improve it.
Public Sub removeBlankEntriesFromRow(inputRow As Range, pasteLocation As String)
'Removes blank entries from inputRow and pastes the result into a row starting at cell pasteLocation
Dim oldArray, newArray, tempArray
Dim j As Integer
Dim i As Integer
'dump range into temp array
tempArray = inputRow.Value
'redim the 1d array
ReDim oldArray(1 To UBound(tempArray, 2))
'convert from 2d to 1d
For i = 1 To UBound(oldArray, 1)
oldArray(i) = tempArray(1, i)
Next
'redim the newArray
ReDim newArray(LBound(oldArray) To UBound(oldArray))
'for each not blank in oldarray, fill into newArray
For i = LBound(oldArray) To UBound(oldArray)
If oldArray(i) <> "" Then
j = j + 1
newArray(j) = oldArray(i)
End If
Next
'Catch Error
If j <> 0 Then
'redim the newarray to the correct size.
ReDim Preserve newArray(LBound(oldArray) To j)
'clear the old row
inputRow.ClearContents
'paste the array into a row starting at pasteLocation
Range(pasteLocation).Resize(1, j - LBound(newArray) + 1) = (newArray)
End If
End Sub
Here is my take on the task you describe:
Option Explicit
Option Base 0
Public Sub removeBlankEntriesFromRow(inputRow As Range, pasteLocation As String)
'Removes blank entries from inputRow and pastes the result into a row starting at cell pasteLocation
Dim c As Range
Dim i As Long
Dim new_array As String(inputRow.Cells.Count - WorksheetFunction.CountBlank(inputRow))
For Each c In inputRow
If c.Value <> vbNullString Then
inputRow(i) = c.Value
i = i + 1
End If
Next
Range(pasteLocation).Resize(1, i - 1) = (new_array)
End Sub
You'll notice that it is quite different, and while it may be slightly slower than your solution, because it is using a for each-loop instead of looping through an array, if my reading of this answer is correct, it shouldn't matter all that much unless the input-range is very large.
It is significantly shorter, as you see, and I find it easier to read - that may just be familiarity with this syntax as opposed to yours though. Unfortunately I'm not on my work-computer atm. to test it out, but I think it should do what you want.
If your main objective is to improve the performance of the code, I think that looking into what settings you may turn off while the code is running will have more effect than exactly what kind of loop and variable assignment you use. I have found this blog to be a good introduction to some concepts to bear in mind while coding in VBA.
I hope you have found my take on your problem an interesting comparison to your own solution, which as others have mentioned should work just fine!
If I am to understand you want to delete blanks and pull the data left on any given row?
I would do it by converting the array to a string joined with pipe |, clean any double pipes out (loop this until there are no doubles left) then push it back to an array across the row:
Here is my code:
Sub TestRemoveBlanks()
Call RemoveBlanks(Range("A1"))
End Sub
Sub RemoveBlanks(Target As Range)
Dim MyString As String
MyString = Join(WorksheetFunction.Transpose(WorksheetFunction.Transpose(Range(Target.Row & ":" & Target.Row))), "|")
Do Until Len(MyString) = Len(Clean(MyString))
MyString = Clean(MyString)
Loop
Rows(Target.Row).ClearContents
Target.Resize(1, Len(MyString) - Len(Replace(MyString, "|", ""))).Formula = Split(MyString, "|")
End Sub
Function Clean(MyStr As String)
Clean = Replace(MyStr, "||", "|")
End Function
I put a sub to test in there for you.
If you have pipes in your data, substitute it with something else in my code.
I made a document in Excel 2010 however, the functionality I'm hoping to get from it doesn't seem to be possible (at least not with the default Excel functions) and I don't know enough about VB programming to make my own UDF. (I'm actually using one I found online which does part of what I want, but doesn't meet all of my needs.)
Let me break it down:
I have multiple sheets with groups of fields where users can add numbers (some will be blank, some will contain a single number, some will contain multiple comma-separated numbers)
I have an "Overview" sheet where I want to Concatenate those numbers (and remove any duplicates) within a few different sections (only looking at specific field groups).
I found a ConcatIf UDF that works fairly well for this, however it can't handle non-consecutive cells to concatenate (For example, I want to concatenate and remove duplicates from cells D30, G30, J30 and M30 together) (Here's the UDF:)
Function ConcatIf(ByVal compareRange As Range, ByVal xCriteria As Variant, Optional ByVal stringsRange As Range, _
Optional Delimiter As String, Optional NoDuplicates As Boolean) As String
Dim i As Long, j As Long
With compareRange.Parent
Set compareRange = Application.Intersect(compareRange, Range(.UsedRange, .Range("a1")))
End With
If compareRange Is Nothing Then Exit Function
If stringsRange Is Nothing Then Set stringsRange = compareRange
Set stringsRange = compareRange.Offset(stringsRange.Row - compareRange.Row, _
stringsRange.Column - compareRange.Column)
For i = 1 To compareRange.Rows.Count
For j = 1 To compareRange.Columns.Count
If (Application.CountIf(compareRange.Cells(i, j), xCriteria) = 1) Then
If InStr(ConcatIf, Delimiter & CStr(stringsRange.Cells(i, j))) <> 0 Imp Not (NoDuplicates) Then
ConcatIf = ConcatIf & Delimiter & CStr(stringsRange.Cells(i, j))
End If
End If
Next j
Next i
ConcatIf = mid(ConcatIf, Len(Delimiter) + 1)
End Function
It also can't handle the "multiple numbers in one cell" as separate numbers.
Is there a way to make a Concatenate UDF that "parses" the cells it's looking at to look for duplicates between the multiple numbers cells and the single numbers cells, and then output the result? Preferably allowing it to take a series of non-consecutive cells to work on (across different sheets).
Sorry if the explanation is a bit convoluted, it's my first time asking for this kind of help. :x
Here's an example:
If I have cells with:
2,4,6
2,6
2
4
6
6,8
I'd want to be able to simply get:
2,4,6,8
Right now, instead, I'd get:
2,4,6,2,6,6,8
Try the below. You can adapt it appropriately if you need to change the delimiter etc. I have documented what it is doing and why.
Example formula: =blah(A1:A7,A8,C9) (it can also be called from code)
Example output: 2,4,6,8
Public Function Blah(ParamArray args()) As String
'Declarations
Dim uniqueParts As Collection
Dim area As Range
Dim arg, arr, ele, part
Dim i As Long
'Initialisations
Set uniqueParts = New Collection
'Enumerate through the arguments passed to this function
For Each arg In args
If TypeOf arg Is Range Then 'range so we need to enumerate its .Areas
For Each area In arg.Areas
arr = area.Value 'for large ranges it is greatly quicker to load the data at once rather than enumerating each cell in turn
For Each ele In arr 'enumerate the array
addParts CStr(ele), uniqueParts 'Call our sub to parse the data
Next ele
Next area
ElseIf VarType(arg) > vbArray Then 'an array has been passed in
For Each ele In arg 'enumerate the array
addParts CStr(ele), uniqueParts 'Call our sub to parse the data
Next ele
Else 'assume can be validly converted to a string. If it cannot then it will fail fast (as intended)
addParts CStr(arg), uniqueParts 'Call our sub to parse the data
End If
Next arg
'process our results
If uniqueParts.Count > 0 Then
ReDim arr(0 To uniqueParts.Count - 1)
For i = 1 To uniqueParts.Count
arr(i - 1) = uniqueParts(i)
Next i
'we now have an array of the unique parts, which we glue together using the Join function, and then return it
Blah = Join(arr, ",")
End If
End Function
'Sub to parse the data. In this case the sub splits the string and adds the split elements to a collection, ignoring duplicates
Private Sub addParts(partsString As String, ByRef outputC As Collection)
'ByRef is unecessary but I use it to document that outputC must be instantiated
Dim part
For Each part In Split(partsString, ",")
On Error Resume Next 'existing same key will raise an error, so we skip it and just carry on
outputC.Add part, part
On Error GoTo 0
Next part
End Sub
Suppose I have an array arr1 which contains date values as below :
Arr1(50)=("9/3/2012 4:57:02 AM","22/3/2012 5:57:02 AM","9/5/2012 8:57:02 AM","9/3/2011 4:57:02 AM")
Edit
Dim CellCount
Dim Arr(10)
CellCount=0
Do Untill arr(CellCount)="" And Ubound(Arr)>9
If CStr(arr(CellCount) < arr(CellCount+1)) Then
MsgBox(arr(CellCount)&"is good")
Else
MsgBox(arr(CellCount +1)&"is bad")
Exit Do
End if
CellCount=CellCount+1
Loop
Now, Is there any direct way,without using any Looping technique,to find out if the Arr1() has the date values ascending or not?
Thanks,
He is answering your question. You asked, is there a way to find if sorted without a loop?
He said no. Your eyes, my eyes can see if it's sorted or not. But how do you expect Excel/computer to do so without going through collections elements?
When data is in an array, you need to loop through its elements. Hope it's clear.
So the best I could say,
split it by the comma delimiter into a variant if required. But not necessary since Array() can put elements into a 1D variant
dump it into a Range using Transpose
use Sheet sorting method/function to sort the range as a whole
---> so you know it's now sorted.
then traspose back into a variant array
Some code snippet to get you going on this direction:
Option Explicit
Sub omgArraySort()
Dim inputArray As Variant
Dim outputArray As Variant
Dim upperB as Long
inputArray = Array("9/3/2012 4:57:02 AM","22/3/2012 5:57:02 AM", _
"9/5/2012 8:57:02 AM","9/3/2011 4:57:02 AM")
'-- sorted array
outputArray = sortRange(inputArray)
upperB = UBound(iArray, 1) '-- for 1D array you may also use UBound(iArray)
If (Err.Number <> 0) Then '-- if there's an error, it's erro code is > 0
MsgBox "Dates sorted, not empty"
End If
End Sub
'-- dump into sheet and sort in the sheet and dump back into the array
Function sortRange(ByVal iArray As Variant) As Variant
Dim rngSort as Range
Dim i As Long
Set rngSort = WorkSheets(1).Range("B2")
i = Ubound(iArray,1)
With rngSort.Resize(i)
.Value = WorksheetFunction.Transpose(iArray)
.Sort rngSort, xlDescending, Header:=xlNo
sortRange = .Value
End With
End Function
In terms of to-from sheet to code traffic can slow down your performance when you are handling large amount of data.
And please do know that when someone in SO who has credibility answers (E.g. Ekkehard's answer) you gotta pay some attention. They don't say it for no proper reason.
No, because you have to check the elements upto/until the first counter example (which could be the last one).
I have the following Data in Excel.
CHM0123456 SRM0123:01
CHM0123456 SRM0123:02
CHM0123456 SRM0256:12
CHM0123456 SRM0123:03
CHM0123457 SRM0789:01
CHM0123457 SRM0789:02
CHM0123457 SRM0789:03
CHM0123457 SRM0789:04
What I need to do is pull out all the relevent SRM numbers that relate to a single CHM ref. now I have a formular that will do some thing like this
=INDEX($C$2:$C$6, SMALL(IF($B$8=$B$2:$B$6, ROW($B$2:$B$6)-MIN(ROW($B$2:$B$6))+1, ""), ROW(A1)))
however this is a bit untidy and I really want to produce this same using short vb script, do i jsut have to right a loop that will run though and check each row in turn.
For x = 1 to 6555
if Ax = Chm123456
string = string + Bx
else
next
which should give me a final string of
SRM0123:01,SRM123:02,SRM0256:12,SRM0123:03
to use with how i want.
Or is ther a neater way to do this ?
Cheers
Aaron
my current code
For x = 2 To 6555
If Cells(x, 1).Value = "CHM0123456" Then
outstring = outstring + vbCr + Cells(x, 2).Value
End If
Next
MsgBox (outstring)
End Function
I'm not sure what your definition of 'neat' is, but here is a VBA function that I consider very neat and also flexible and it's lightning fast (10k+ entires with no lag). You pass it the CHM you want to look for, then the range to look in. You can pass a third optional paramater to set how each entry is seperated. So in your case you could write (assuming your list is :
=ListUnique(B2, B2:B6555)
You can also use Char(10) as the third parameter to seperat by line breaks, etc.
Function ListUnique(ByVal search_text As String, _
ByVal cell_range As range, _
Optional seperator As String = ", ") As String
Application.ScreenUpdating = False
Dim result As String
Dim i as Long
Dim cell As range
Dim keys As Variant
Dim dict As Object
Set dict = CreateObject("scripting.dictionary")
On Error Resume Next
For Each cell In cell_range
If cell.Value = search_text Then
dict.Add cell.Offset(, 1).Value, 1
End If
Next
keys = dict.keys
For i = 0 To UBound(keys)
result = result & (seperator & keys(i))
Next
If Len(result) <> 0 Then
result = Right$(result, (Len(result) - Len(seperator)))
End If
ListUnique = result
Application.ScreenUpdating = True
End Function
How it works: It simple loops through your range looking for the search_string you give it. If it finds it, it adds it to a dictionary object (which will eliminate all dupes). You dump the results in an array then create a string out of them. Technically you can just pass it "B:B" as the search array if you aren't sure where the end of the column is and this function will still work just fine (1/5th of a second for scanning every cell in column B with 1000 unique hits returned).
Another solution would be to do an advancedfilter for Chm123456 and then you could copy those to another range. If you get them in a string array you can use the built-in excel function Join(saString, ",") (only works with string arrays).
Not actual code for you but it points you in a possible direction that can be helpful.
OK, this might be pretty fast for a ton of data. Grabbing the data for each cell takes a ton of time, it is better to grab it all at once. The the unique to paste and then grab the data using
vData=rUnique
where vData is a variant and rUnique is the is the copied cells. This might actually be faster than grabbing each data point point by point (excel internally can copy and paste extremely fast). Another option would be to grab the unique data without having the copy and past happen, here's how:
dim i as long
dim runique as range, reach as range
dim sData as string
dim vdata as variant
set runique=advancedfilter(...) 'Filter in place
set runique=runique.specialcells(xlCellTypeVisible)
for each reach in runique.areas
vdata=reach
for i=lbound(vdata) to ubound(vdata)
sdata=sdata & vdata(i,1)
next l
next reach
Personally, I would prefer the internal copy paste then you could go through each sheet and then grab the data at the very end (this would be pretty fast, faster than looping through each cell). So going through each sheet.
dim wks as worksheet
for each wks in Activeworkbook.Worksheets
if wks.name <> "CopiedToWorksheet" then
advancedfilter(...) 'Copy to bottom of list, so you'll need code for that
end if
next wks
vdata=activeworkbook.sheets("CopiedToWorksheet").usedrange
sData=vdata(1,1)
for i=lbound(vdata) + 1 to ubound(vdata)
sData=sData & ","
next i
The above code should be blazing fast. I don't think you can use Join on a variant, but you could always attempt it, that would make it even faster. You could also try application.worksheetfunctions.contat (or whatever the contatenate function is) to combine the results and then just grab the final result.
On Error Resume Next
wks.ShowAllData
On Error GoTo 0
wks.UsedRange.Rows.Hidden = False
wks.UsedRange.Columns.Hidden = False
rFilterLocation.ClearContents