I've got two ranges in excel.
I need to do the following:
1). Count how many equal values I have, apart from zero. In my example it should be 2 (1 and 8). I found this formula: SUMPRODUCT(--(A2:E2=A3:E3)), but it will match only B1, B2, ignoring that number 8 appeared two times as well.
2). Separately, I need to have these repeated values in a single cell, separated with comma, just like "1,8".
Try this SUM over COUNTIFS array¹ formula,
=SUM(COUNTIFS(A2:E2, "<>"&0, A2:E2, A3:E3))
¹ Array formulas need to be finalized with Ctrl+Shift+Enter↵. Once entered into the first cell correctly, they can be filled or copied down or right just like any other formula. Try and reduce your full-column references to ranges more closely representing the extents of your actual data. Array formulas chew up calculation cycles logarithmically so it is good practise to narrow the referenced ranges to a minimum. See Guidelines and examples of array formulas for more information.
For the latter half of your question, I'll offer this rudimentary UDF which strings together the matched values. As a programming enthusiast you should get great pleasure in modifying the code to include a frequency count.
Function stringMatches(rng1 As Range, rng2 As Range, _
Optional sDELIM As String = ", ", _
Optional bNOZERO As Boolean = True)
Dim sTMP As String, rng As Range
stringMatches = vbNullString
For Each rng In rng1
If (CBool(Application.CountIf(rng2, rng.Value)) And Not bNOZERO) Or _
(CBool(Application.CountIfs(rng2, "<>" & 0, rng2, rng.Value)) And bNOZERO) Then
sTMP = sTMP & rng.Value & sDELIM
End If
Next rng
If CBool(Len(sTMP)) Then _
stringMatches = Left(sTMP, Len(sTMP) - Len(sDELIM))
End Function
simply use this (non array) formula:
=SUMPRODUCT((COUNTIFS(A2:E2,"<>0",A2:E2,A3:E3)>0)*1)
but for the second part, i don't think there is a dynamically way without VBA :/
as UDF i suggest something like this: (for the second part only)
Public Function getDoubles(rng1 As Range, rng2 As Range) As String
Dim cell As Variant, str As String
For Each cell In rng1.Value
If cell <> 0 And Not IsError(Application.Match(cell, rng2, 0)) Then str = str & cell & ", "
Next
getDoubles = Left(str, Len(str) - 2)
End Function
But keep in mind: having a value multiple times in one range, the formula/UDF will pretty much likely mess up
To do it in a clean way (skipping all doubles) you can use this:
Public Function getDoubles(rng1 As Range, rng2 As Range, Optional getList As Boolean, Optional compType As VbCompareMethod = vbTextCompare) As Variant
If rng1.Count = 1 Then
getDoubles = Not IsError(Application.Match(rng1.Value, rng2, 0))
Exit Function
ElseIf rng2.Count = 1 Then
getDoubles = Not IsError(Application.Match(rng2.Value, rng1, 0))
Exit Function
End If
Dim tempCol As New Collection
Dim colItem As Variant
Dim isInCol As Boolean
Dim rngItem As Variant
For each rngItem in rng1.Value
isInCol = False
If Len(rngItem) > 0 And rngItem <> 0 Then 'remove the "And getOut <> 0" to do it also for 0's
For Each colItem In tempCol
isInCol = (StrComp(colItem, rngItem, compType) = 0)
If isInCol Then Exit For
Next
If Not isInCol Then tempCol.Add rngItem
End If
Next
Dim getOut As Variant
If getList Then
getOut = ""
Else
getOut = 0
End If
For Each colItem In tempCol
For Each rngItem In rng2
If StrComp(colItem, rngItem, compType) = 0 Then
If getList Then
getOut = getOut & colItem & ", "
Else
getOut = getOut + 1
End If
Exit For
End If
Next
Next
If getList Then
getDoubles = Left(getOut, Len(getOut) - 2)
Else
getDoubles = getOut
End If
End Function
If one (or both) range is only one item, it will return true if it is inside the other range, else it will be false.
Having 2 ranges of at least 2 cells it will output as folows without doubles:
=getDoubles(range1,range2) = the count of matches
=getDoubles(range1,range2,1) = the "," separated list of matches
=getDoubles(range1,range2,0,0) = like the first but case sensitive
=getDoubles(range1,range2,1,0) = like the second but case sensitive
Try this simple UDF():
Public Function compare(r1 As Range, r2 As Range) As Long
Dim r As Range, v As Variant, v2 As Variant
Dim rr As Range
For Each r In r1
v = r.Value
If v <> 0 And v <> "" Then
For Each rr In r2
v2 = rr.Value
If v = v2 Then compare = compare + 1
Next rr
End If
Next r
End Function
User Defined Functions (UDFs) are very easy to install and use:
ALT-F11 brings up the VBE window
ALT-I
ALT-M opens a fresh module
paste the stuff in and close the VBE window
If you save the workbook, the UDF will be saved with it.
If you are using a version of Excel later then 2003, you must save
the file as .xlsm rather than .xlsx
To remove the UDF:
bring up the VBE window as above
clear the code out
close the VBE window
To use the UDF from Excel:
=myfunction(A1)
To learn more about macros in general, see:
http://www.mvps.org/dmcritchie/excel/getstarted.htm
and
http://msdn.microsoft.com/en-us/library/ee814735(v=office.14).aspx
and for specifics on UDFs, see:
http://www.cpearson.com/excel/WritingFunctionsInVBA.aspx
Macros must be enabled for this to work!
NOTE:
If there are 4 qwerty in the second range, you will get a count for each one. (but a slight mod can avoid this)
This routine will return the CSV:
Public Function compare2(r1 As Range, r2 As Range) As String
Dim r As Range, v As Variant, v2 As Variant
Dim rr As Range
For Each r In r1
v = r.Value
If v <> 0 And v <> "" Then
For Each rr In r2
v2 = rr.Value
If v = v2 Then compare2 = compare2 & "," & CStr(v)
Next rr
End If
Next r
If compare2 <> "" Then compare2 = Mid(compare2, 2)
End Function
Related
I've been trying to find/write a macro that opens all hyperlinks contained in a selected range at once. The code I've come across works on only some types of hyperlinks, specifically hyperlinks added through either the right click/Insert>Link/Ctrl+K. The code wont recognise any hyperlinks that are formed using the HYPERLINK() function.
Here's the code I found online:
Sub OpenMultipleLinks()
On Error Resume Next
Set myRange = Application.Selection
Set myRange = Application.InputBox("Range", "OpenMultipleLinks", myRange.Address, Type:=8)
For Each oneLink In myRange.Hyperlinks
oneLink.Follow
Next
End Sub
And here's the formula of a cell that becomes a hyperlink.
=IF($D2="All Charts","",HYPERLINK("http://SubstituteWebsite/ChartId="&$D2&$AF$1,"link"))
Since you do not answer my clarification questions, I will assume that my understanding is correct. So, the following code will work if your formulae containing 'HYPERLINK' formula inside respect the pattern you show us and it should be followed without evaluating if the formula condition is True:
Sub OpenMultipleLinks()
Dim myrange As Range, cel As Range, oneLink
On Error Resume Next
Set myrange = Application.Selection
Set myrange = Application.InputBox("Range", "OpenMultipleLinks", myrange.Address, Type:=8)
For Each oneLink In myrange.Hyperlinks
oneLink.Follow
Next
On Error GoTo 0
For Each cel In myrange
If InStr(cel.Formula, "HYPERLINK") > 0 Then
ActiveWorkbook.FollowHyperlink extractHypFromFormula(ActiveCell.Formula)
End If
Next
End Sub
Function extractHypFromFormula(strForm As String) As String
Dim Hpos As Long, startP As Long, Hlength As Long, strRoot As String
Dim startP2 As Long, cellsAddr As String
Hpos = InStr(strForm, "HYPERLINK") 'it returns position of the first character for "HYPERLINK" string in the formula
If Hpos > 0 Then
startP = Hpos + Len("HYPERLINK") + 2 'it builds the position after which to start searching
'+ 2 because of '(' and "
Hlength = InStr(startP, strForm, """") - startP 'length of the hyperlink fix part (before the strings taken from the two cells value)
strRoot = Mid(strForm, startP, Hlength) 'it returns the hyperlink fix part
startP2 = startP + Len(strRoot) + 2 'next START to return the string keeping the concatenation of the two cells value
cellsAddr = Mid(strForm, startP2, InStr(startP2, strForm, ",") - startP2) 'the string keeping the concatenation of the two cells value
'split the string on "&" separator and use the two elements as range string:
extractHypFromFormula = strRoot & Range(Split(cellsAddr, "&")(0)).value & Range(Split(cellsAddr, "&")(1)).value
End If
End Function
Please, send some feedback after testing it...
You need to parse/evaluate the "hyperlink" formula first. Assuming all your links are in col A this will do what you want:
Sub link()
Dim arr, arr2, j As Long
arr = Sheet1.Range("A1").CurrentRegion.Formula2 'get all in an array
For j = 1 To UBound(arr)
If Left(arr(j, 1), 3) = "=HY" Then 'check if it's a formula
arr(j, 1) = Evaluate(Split(Mid(arr(j, 1), 2), ",")(0) & ")") 'split the url from the rest, evaluate and replace in array
End If
ActiveWorkbook.FollowHyperlink Address:=arr(j, 1), NewWindow:=True 'open in default browser
Next j
End Sub
Best of luck,
ceci
Alright, this is a very specific question. I have an excel macro written that takes a web URL, delimits it, transposes it, and then adds adjacent columns that describe the information in the originally transposed columns. Now, I need to add something to my macro that will loop through and check if the first character of one cell matches one of the first 4 characters of another cell. If it does, I need to concatenate strings from the descriptive columns to new cells. I'll illustrate this below:
3,435,201,0.5,%22type%25202%2520diabetes%22,0 Node type 2 diabetes
4,165,97,0.5,%22diet%22,0 Node diet
5,149,248,0.5,%22lack%2520of%2520exercise%22,2 Node lack of exercise
6,289,329,0.5,%22genetics%22,3 Node genetics
7,300,71,0.5,%22blood%2520pressure%2520%22,5 Node blood pressure
7,3,-7,1,0 Arrow +
4,3,-21,1,0 Arrow +
5,3,-22,1,0 Arrow +
6,3,-34,1,0 Arrow +
,7%5D Tail
I added color to make the concept of the problem more easily visualized. In row one of the first column, we see a red 3 that corresponds to 'type 2 diabetes'. In the fifth row of the first column, we see a blue 7 that corresponds to 'blood pressure'. These are both node objects, as the adjacent column signifies. In the sixth cell of the first column we see a blue 7 and a red 3. This indicates that an arrow (also signified by adjacent column) is connecting blood pressure to diabetes. In the next column over, we see an orange plus sign, which indicates this is a positive relationship.
The goal is to populate the next column over with "blood pressure + type diabetes", as I demonstrated in the image. So, I need some code to check the first characters in each node cell, and then compare them to the first 4 characters of each arrow cell. When an arrow that matches two of the nodes is found, I need the code to populate the row next to the + signs with a concatenated string comprised of the names of the nodes pertaining to that arrow, as well as the + sign between them (it's possible that it could also be a minus sign, but one isn't present in this example). Any pointers? I can't wrap my head around this. Edited to add Data
Here is the code of my current macro:
Sub Delimit_Transpose()
Cells.Replace What:="],[", Replacement:="#", LookAt:=xlPart, SearchOrder _
:=xlByRows, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False
ActiveCell.FormulaR1C1 = "=RIGHT(R[-1]C,LEN(R[-1]C)-36)"
Dim i As Long, strTxt As String
Dim startP As Range
Dim xRg As Range, yRg As Range
On Error Resume Next
Set xRg = Application.InputBox _
(Prompt:="Range Selection...", _
Title:="Delimit Transpose", Type:=8)
i = 1
Application.ScreenUpdating = False
For Each yRg In xRg
If i = 1 Then
strTxt = yRg.Text
i = 2
Else
strTxt = strTxt & "," & yRg.Text
End If
Next
Application.ScreenUpdating = True
Set startP = Application.InputBox _
(Prompt:="Paste Range...", _
Title:="Delimit Transpose", Type:=8)
ary = Split(strTxt, "#")
i = 1
Application.ScreenUpdating = False
For Each a In ary
startP(i, 1).Value = Replace(Replace(a, "[", ""), "]", "")
i = i + 1
Next a
i = 1
For Each a In ary
If Len(a) > 13 Then
startP.Offset(i - 1, 1).Value = "Node"
ElseIf Len(a) < 13 And Len(a) > 6 Then
startP.Offset(i - 1, 1).Value = "Arrow"
Else
startP.Offset(i - 1, 1).Value = "Tail"
End If
i = i + 1
Next a
Dim openPos As Integer
Dim closePos As Integer
Dim midBit As String
i = 1
n = 5
For Each a In ary
openPos = InStr(a, ",%22")
On Error Resume Next
closePos = InStr(a, "%22,")
On Error Resume Next
midBit = Mid(a, openPos + 1, closePos - openPos - 1)
On Error Resume Next
If openPos <> 0 And Len(midBit) > 0 Then
startP.Offset(i - 1, 2).Value = Replace(Replace(midBit, "%22", ""), "%2520", " ")
ElseIf Len(a) < 13 And InStr(a, "-") = 4 Then
startP.Offset(i - 1, 2).Value = "'-"
ElseIf Len(a) < 7 Then
startP.Offset(i - 1, 2).Value = " "
Else
startP.Offset(i - 1, 2).Value = "+"
End If
i = i + 1
n = n + 1
Next a
Application.ScreenUpdating = True
End Sub
This is my approach.
There's room for a lot of improvements, but is a rough code that should get you started.
Read the code's comments and adapt it to fit your needs.
EDIT: I updated the code to match the sample worksheet you uploaded, build the first column range dinamically, validate if commas appear in the first column cell so no error is raised.
As I said in the comments, it's better easier to debug if you call one procedure from the other, instead of merging them.
Code:
Option Explicit
Public Sub StoreConcatenate()
' Basic error handling
On Error GoTo CleanFail
' Define general parameters
Dim targetSheetName As String
targetSheetName = "Test space" ' Sheet holding the data
Dim firstColumnLetter As String
firstColumnLetter = "C" ' First column holding the numbers
Dim firstColumnStartRow As Long
firstColumnStartRow = 7
' With these three parameters we'll build the range address holding the first column dynamically
' Set reference to worksheet
Dim targetSheet As Worksheet
Set targetSheet = ThisWorkbook.Worksheets(targetSheetName)
' Find last row in column (Modify on what column)
Dim firstColumnlastRow As Long
firstColumnlastRow = targetSheet.Cells(targetSheet.Rows.Count, firstColumnLetter).End(xlUp).Row
' Build range of first column dinamically
Dim firstColumnRange As Range
Set firstColumnRange = targetSheet.Range(firstColumnLetter & firstColumnStartRow & ":" & firstColumnLetter & firstColumnlastRow)
' Loop through first column range cells
Dim valueCell As Range
For Each valueCell In firstColumnRange
' Check if cell contains "," in the second position in string
If InStr(valueCell.Value, ",") = 2 Then
' Store first digit of cell before ","
Dim firstDigit As Integer
firstDigit = Split(valueCell.Value, ",")(0)
' Check if cell contains "," in the fourth position in string
If InStr(3, valueCell.Value, ",") = 4 Then
' Store second digit of cell after ","
Dim secondDigit As Integer
secondDigit = Split(valueCell.Value, ",")(1)
End If
' Store second colum type
Dim secondColumnType As String
secondColumnType = valueCell.Offset(, 1).Value
' Store third column value
Dim thirdColumnValue As String
thirdColumnValue = valueCell.Offset(, 2).Value
' Store nodes values (first digit and second column type)
Select Case secondColumnType
Case "Node"
Dim nodeValues() As Variant
Dim nodeCounter As Long
ReDim Preserve nodeValues(nodeCounter)
nodeValues(nodeCounter) = Array(firstDigit, thirdColumnValue)
nodeCounter = nodeCounter + 1
Case "Arrow"
Dim matchedNodeFirstValue As String
Dim matchedNodeSecondValue As String
matchedNodeFirstValue = IsInArrayReturnItem(firstDigit, nodeValues)(1)
matchedNodeSecondValue = IsInArrayReturnItem(secondDigit, nodeValues)(1)
If matchedNodeFirstValue <> vbNullString And matchedNodeSecondValue <> vbNullString Then
valueCell.Offset(, 3).Value = matchedNodeFirstValue & Space(1) & thirdColumnValue & Space(1) & matchedNodeSecondValue
End If
End Select
End If
Next valueCell
CleanExit:
Exit Sub
CleanFail:
Debug.Print "Something went wrong: " & Err.Description
Resume CleanExit
End Sub
' Credits: https://stackoverflow.com/a/38268261/1521579
Public Function IsInArrayReturnItem(stringToBeFound As Integer, arr As Variant) As Variant
Dim i
For i = LBound(arr) To UBound(arr)
If arr(i)(0) = stringToBeFound Then
IsInArrayReturnItem = arr(i)
Exit Function
End If
Next i
IsInArrayReturnItem = Array(vbNullString, vbNullString)
End Function
Let me know if it works
It appears that you are concatenating the lookups based on the
first and second integers,
where the second column = "Arrow"
If that is the case, I suggest:
Read the data table into a VBA array for faster processing
I am assuming your data is ordered as you show it, with all the Node entries at the start.
if that is not the case, then loop twice -- once to find the Nodes, and second time to concatenate the Arrow data.
Read the diagnoses into a dictionary for fact lookup.
if column2 = "Arrow" then concatenate the lookups of the first and second integers
Write back the data
Note: As written, this will overwrite the original table destroying any formulas that might be there. If needed, you could easily modify it to only overwrite the necessary area.
Note2 Be sure to set a reference (under Tools/References) to Microsoft Scripting Runtime, or change the Dictionary declaration to late-binding.
Regular Module
'set reference to Microsoft Scripting Runtime
Option Explicit
Sub Dx()
Dim WS As Worksheet
Dim rngData As Range, c As Range, vData As Variant
Dim dDx As Dictionary
Dim I As Long, sKey As String, dxKeys As Variant
'Get the data range
Set WS = ThisWorkbook.Worksheets("sheet1")
With WS
'assume table starts in A1 and is three columns wide
Set rngData = .Range(.Cells(1, 1), .Cells(.Rows.Count, 1).End(xlUp)).Resize(columnsize:=3)
'read into variant array for faster processing
vData = rngData
End With
'create dictionsry for dx lookups
Set dDx = New Dictionary
For I = 2 To UBound(vData, 1)
Select Case vData(I, 2)
Case "Node"
sKey = Split(vData(I, 1), ",")(0) 'first comma-separated number
If dDx.Exists(sKey) Then
MsgBox "duplicate diagnostic key. Please correct the data"
Exit Sub
End If
dDx.Add Key:=sKey, Item:=vData(I, 3)
Case "Arrow"
dxKeys = Split(vData(I, 1), ",")
vData(I, 3) = dDx(dxKeys(0)) & " + " & dDx(dxKeys(1))
End Select
Next I
'reWrite the table
Application.ScreenUpdating = False
rngData = vData
End Sub
I have code that loops through the 5th column of a user-selected range, and if the current cell in the 5th column matches a criteria, adds the next 10 cells in the same row to a range. At the end of everything, it sums the final range in cell A1 if it is empty.
Sub SumItems()
Dim selectedRange As Range
Set selectedRange = Selection
Dim sumRange As Range
Dim i As Long
For i = 1 To selectedRange.Rows.Count
If selectedRange(i, 5) = "Yes" Then
If sumRange Is Nothing Then
Set sumRange = Range(selectedRange(i, 5).Offset(0, 1), selectedRange(i, 5).Offset(0, 10))
Else
Set sumRange = Union(sumRange, Range(selectedRange(i, 5).Offset(0, 1), selectedRange(i, 5).Offset(0, 10)))
End If
End If
Next i
If Not sumRange Is Nothing Then
If IsEmpty(Range("A1")) Then
Range("A1").Formula = "=SUM(" + sumRange.Address(False, False) + ")"
Else
MsgBox "Cannot paste in cell A1, it is not empty."
Exit Sub
End If
Else
MsgBox "No matching rows were found."
Exit Sub
End If
End Sub
The sheets I am running this on are long. So sumRange will usually be a union of a lot of different areas in the sheet. I've noticed that once sumRange.Areas.Count exceeds 18, I have problems with the Range("A1").Formula statement. The sumRange.Address(False, False) string gets cut off after the 18th area. I believe this is because the .Address string length is too long and it just coincides with 18 areas with this sheet.
I developed a temporary solution but it limits the number of areas the subroutine can handle and is clunky and verbose. I set up temporary range variables to split sumRange into if it has more than 18 areas and the IF statement now reads something like:
If Not sumRange Is Nothing Then
If IsEmpty(Range("A1")) Then
If sumRange.Areas.Count > 18 Then
Dim k As Long
Dim tmpSumRange1 As Range
Dim tmpSumRange2 As Range
Dim tmpSumRange3 As Range
' And so on...
For k = 1 To sumRange.Areas.Count
If k <= 18 Then
If tmpSumRange1 Is Nothing Then
Set tmpSumRange1 = sumRange.Areas(k)
Else
Set tmpSumRange1 = Union(tmpSumRange1, sumRange.Areas(k))
End If
ElseIf k > 18 And k <= 36 Then
If tmpSumRange2 Is Nothing Then
Set tmpSumRange2 = sumRange.Areas(k)
Else
Set tmpSumRange2 = Union(tmpSumRange2, sumRange.Areas(k))
End If
ElseIf k > 36 And k <= 54 Then
If tmpSumRange3 Is Nothing Then
Set tmpSumRange3 = sumRange.Areas(k)
Else
Set tmpSumRange3 = Union(tmpSumRange3, sumRange.Areas(k))
End If
ElseIf
' And so on until I get to k = 180...
End If
Next k
If Not tmpSumRange1 Is Nothing And tmpSumRange2 Is Nothing And tmpSumRange3 Is Nothing Then
Range("A1").Formula = "=SUM(" + tmpSumRange1.Address(False, False) + ")"
ElseIf Not tmpSumRange1 Is Nothing And Not tmpSumRange2 Is Nothing And tmpSumRange3 Is Nothing Then
Range("A1").Formula = "=SUM(" + tmpSumRange1.Address(False, False) + "," + tmpSumRange2.Address(False, False) + ")"
ElseIf Not tmpSumRange1 Is Nothing And tmpSumRange2 Is Nothing And Not tmpSumRange3 Is Nothing Then
Range("A1").Formula = "=SUM(" + tmpSumRange1.Address(False, False) + "," + tmpSumRange2.Address(False, False) + "," + tmpSumRange3.Address(False, False) + ")"
ElseIf
' And so on all the way up to tmpSumRange10...
End If
Else
Range("A1").Formula = "=SUM(" + sumRange.Address(False, False) + ")"
End If
Else
MsgBox "Cannot paste in cell A1, it is not empty."
Exit Sub
End If
Else
MsgBox "No matching rows were found."
Exit Sub
End If
I know there has to be a better solution than this. I haven't found anything in my searching. Nor have I found anyone that has experienced the same problem. I need the A1 cell to have the SUM formula with the ranges in it otherwise I would just sum the values in the subroutine and insert the value instead of the formula.
So there are two separate but probably related issues:
Range.Address truncates at a maximum of 255 characters, without error. This is odd, because while Excel is smart enough to not leave you with a partial address string that would raise a 1004, at the same time it's stupid enough to allow an Address to truncate, which obviously will yield unexpected results if used in formula, etc.
There's a kinda-sorta 255 character limit for string arguments to Excel functions if the string is passed ByVal (see this old thread) for discussion, but I've excerpted relevant bits, below) .
Excel function parameters will accept a reference to a string with length of up to 32767 (32k or 2^15 total possible lengths). ... But what if we pass a value instead of a reference?
we can pass a reference to a string up to 32k, we can only pass a string value up to 255
It seemed like the problem was a result of Formula length, but that was a red herring.
You're definitely encountering the truncation issue with Range.Address.
Problem: Range.Address truncates at 255 Characters
Because this happens silently, any formula you build based on truncated address is going to be adversely affected; the results won't be what you're expecting because the formula will not represent all parts of the range!
I've logged this as a bug with Microsoft in case you want to follow the issue:
https://github.com/MicrosoftDocs/VBA-Docs/issues/49
In the meantime, fortunately the solution is remarkably simple (although it was not simple to arrive at!), see if you can adapt to your purposes, but the idea is:
Create a System.Collections.ArrayList into which we store all of the individual Area addresses (alternatively you could use a Variant but those are somewhat clunkier what with the ReDim etc.)
Cast that ArrayList to a variant array using the ToArray() method
Use the result of the Join function in your Formula string
Sub example()
Dim myNames As Object
Dim formula as String
Dim k As Long
Dim sumRange As Range
Dim thisArea As Range
' Example:
' -- creates a range consisting of 100 Areas
' -- this .Address will truncate to 252 characters!
For k = 1 To 200 Step 2
Set thisArea = Range("A" & k)
If sumRange Is Nothing Then Set sumRange = thisArea
Set sumRange = Union(sumRange, thisArea)
Next
' Iterate the sumRange union and add each Area to an ArrayList
Set myNames = CreateObject("System.Collections.ArrayList")
For Each thisArea In sumRange.Areas
myNames.Add thisArea.Address
Next
' Output to worksheet:
Dim outputCell As Range
Set outputCell = Range("F1")
formula = "=Sum(" & Join(myNames.ToArray(), ",") & ")"
outputCell.Formula = formula
End Sub
And you can see the extraordinarily long formula (Len == 650) in the worksheet:
If you're not comfortable working with an ArrayList, you could brute force it as a `String:
' Iterate the sumRange union and add each Area to our formula string
formula = "=Sum("
For Each thisArea In sumRange.Areas
formula = formula & thisArea.Address & ","
Next
formula = Left(formula, Len(formula) - 1)
formula = formula & ")"
I am trying to get the values of the visible cells of a range into an array.
My code makes the array carry the values until the first non visible cell then stops.
Public Function ListeMaschinen() As Variant
Dim Auswahl As Range
With Sheets("qry_TechnischesDatenblatt")
Set Auswahl = .Range(.Range("A2:B2"), .Range("A2:B2").End(xlDown)).SpecialCells(xlCellTypeVisible)
End With
ListeMaschinen = Auswahl
End Function
If I select the range it shows all the cells I want marked.
Auswahl.Select
Here I have added the range cells to an array.
Sub examp()
Dim rng As Range, cll As Range, i As Integer, a(100) As Variant
Set rng = Range(Range("A2:B2"), Range("A2:B2").End(xlDown)).SpecialCells(xlCellTypeVisible)
i = 0
For Each cll In rng
a(i) = cll.Value
i = i + 1
Next
End Sub
In your code, you are setting a Variant variable equal to a Range object without using the Set statement.
The following works with the little testing I did. Of course, if you declare the function type and other variables as Range type, it also works.
Option Explicit
Sub test()
Dim myVar As Variant
Set myVar = myList()
Debug.Print myVar.Address
End Sub
Public Function myList() As Variant
Dim myRng As Range
With Sheets("Sheet1")
Set myRng = .Range(.Range("A1:B1"), .Range("A1:B1").End(xlDown)).SpecialCells(xlCellTypeVisible)
End With
Debug.Print myRng.Address
Set myList = myRng
End Function
I think your issue is related to
.SpecialCells(xlCellTypeVisible)
When I do this:
Public Function ListeMaschinen() As Variant
Dim Auswahl As Range
With Sheets("qry_TechnischesDatenblatt")
Set Auswahl = .Range(.Range("A2:B2"), .Range("A2:B2").End(xlDown)).SpecialCells(xlCellTypeVisible)
End With
MsgBox Auswahl.Address
Set ListeMaschinen = Auswahl
'Auswahl.Select
End Function
I get an Address composed of 2 parts: the visible parts!
But when I remove the SpecialCells
Public Function ListeMaschinen() As Variant
Dim Auswahl As Range
With Sheets("qry_TechnischesDatenblatt")
Set Auswahl = .Range(.Range("A2:B2"), .Range("A2:B2").End(xlDown))
End With
MsgBox Auswahl.Address
Set ListeMaschinen = Auswahl
End Function
I get one single part, which Is what I get when using Select too.
I tested!
Sub test()
Dim myVar As Variant
Dim i As Integer
i = 0
Set myVar = ListeMaschinen()
For Each C In myVar
i = i + 1
MsgBox C.Value & C.Address & "-" & i
Next
End Sub
Further to my comments earlier, here is a method that will work subject to some limitations:
You can't have more than 65536 rows of data; and
You can't have really long text (911 chars+), or blank visible cells; and
The data should not contain the string "|~|"
If those conditions are met, you can use something like this:
Dim v
Dim sFormula As String
With Selection
sFormula = "IF(SUBTOTAL(103,OFFSET(" & .Cells(1).Address(0, 0) & ",row(" & .Address(0, 0) & ")-min(row(" & .Address(0, 0) & ")),1))," & .Address(0, 0) & ",""|~|"")"
End With
Debug.Print sFormula
v = Filter(Application.Transpose(Evaluate(sFormula)), "|~|", False)
You can adapt this to work round the third limitation by changing the alternate text in the formula string.
Hello :) I was trying to find a way to loop through visible rows in a table without going through all the rows and checking if they are visible as this was consuming too much time on a large table. Below is the solution I was able to come up with. It is a function that returns an array of the absolute row numbers of visible rows in a given Range.
Function GetVisibleRows(LookupRange As Range) As Integer()
Dim VisibleRange As Range, Index As Integer, Area As Range
Static VisibleRows() As Integer
Set VisibleRange = LookupRange.SpecialCells(xlCellTypeVisible)
ReDim VisibleRows(0)
Index = 0
For Each Area In VisibleRange.Areas
If Index = 0 Then
VisibleRows(Index) = Area.Row
ReDim Preserve VisibleRows(Index + 1)
End If
Index = UBound(VisibleRows())
If VisibleRows(Index - 1) <> Area.Row Then
VisibleRows(Index) = Area.Row
ReDim Preserve VisibleRows(Index + 1)
End If
Next
' Remove last empty item
ReDim Preserve VisibleRows(UBound(VisibleRows()) - 1)
GetVisibleRows = VisibleRows
End Function
If you would like to use this function in a lookup scenario, you need to convert the absolute row numbers returned by the function to relative row numbers of the table. Following worked for me.
RowIndex = ReturnedRowIndex - LookupRange.Rows(1).Row + 1
Good luck!
I have a number of ranges to concatenate independently and put the values of the concatenated ranges into different cells.
I want to:
concatenate values in Range A1:A10 and put the result in F1
then concatenate the Range B1:B10 and put the result in F2
then concatenate the Range C1:C10 and put the result in F3 etc.
The following macro concatenates range A1:A10 and then puts the results into F1 (which is what I want). However it also stores the information from the first concatenation into memory so that when it does the next concatenation, in cell F2 I get the concatenated results of F1 and F2 joined.
Sub concatenate()
Dim x As String
Dim Y As String
For m = 2 To 5
Y = Worksheets("Variables").Cells(m, 5).Value
'Above essentially has the range information e.g. a1:a10 in sheet variables
For Each Cell In Range("" & Y & "") 'i.e. range A1:A10
If Cell.Value = "" Then GoTo Line1 'this tells the macro to continue until a blank cell is reached
x = x & Cell.Value & "," 'this provides the concatenated cell value
Next
Line1:
ActiveCell.Value = x
ActiveCell.Offset(1, 0).Select
Next m
End Sub
Here is my ConcatenateRange. It allows you to add a seperator if you please. It is optimized to handle large ranges since it works by dumping the data in a variant array and working with it within VBA.
You would use it like this:
=ConcatenateRange(A1:A10)
The code:
Function ConcatenateRange(ByVal cell_range As range, _
Optional ByVal seperator As String) As String
Dim newString As String
Dim cellArray As Variant
Dim i As Long, j As Long
cellArray = cell_range.Value
For i = 1 To UBound(cellArray, 1)
For j = 1 To UBound(cellArray, 2)
If Len(cellArray(i, j)) <> 0 Then
newString = newString & (seperator & cellArray(i, j))
End If
Next
Next
If Len(newString) <> 0 Then
newString = Right$(newString, (Len(newString) - Len(seperator)))
End If
ConcatenateRange = newString
End Function
... I would do this very differently... Why not create a function along the lines of:
Function ConcatMe(Rng As Range) As String
Dim cl As Range
ConcatMe = ""
For Each cl In Rng
ConcatMe = ConcatMe & cl.Text
Next cl
End Function
And then just, for example, set F1 = ConcatMe(A1:A10) or, then write code to assign the function to the cells you want...
Or, as #KazJaw mentioned in his comment, just set x="" before re-looping.
Hope this helps
it is similar to the idea posted here already. However, I use a for each loop instead of an array setup with nested for loops.
Function ConcRange(ByRef myRange As Range, Optional ByVal Seperator As String = "")
ConcRange = vbNullString
Dim rngCell As Range
For Each rngCell In myRange
If ConcRange = vbNullString Then
If Not rngCell.Value = vbNullString Then
ConcRange = CStr(rngCell.Value)
End If
Else
If Not rngCell.Value = vbNullString Then
ConcRange = ConcRange & Seperator & CStr(rngCell.Value)
End If
End If
Next rngCell
End Function
This, I suppose would be faster than the array set up, as a new array is not created each time this function runs.
Right before Next m insert simple statement: x="" – KazimierzJawor Apr 8 '13 at 20:43
took me several minutes to notice this answer was under comments :p
Thanks for everything guys, for my purpose I have modified your suggestions and amended my code as it didn't quite fit into a neat function as I needed it to be more dynamic. See my code below. It does exactly what I need.
Sub concatenate()
Dim x As String
Dim Y As String
For Q = 1 To 10 'This provides a column reference to concatenate - Outer For statement
For T = 1 To 10 'This provides a rows reference to concatenate - Inner for statement
For Each Cell In Cells(T, Q) 'provides rows and column reference
If Cell.Value = "" Then GoTo Line1 'this tells the macro to continue until a blank cell is reached
x = x & Cell.Value & "," 'This provides the concatenated cell value and comma separator
Next ' this loops the range
Next T 'This is the inner loop which dynamically changes the number of rows to loop until a blank cell is reached
Line1:
On Error GoTo Terminate 'Terminates if there are less columns (max 10) to concatenate
ActiveCell.Value = Mid(x, 1, Len(x) - 1) 'This basically removes the last comma from the last concatenated cell e.g. you might get for a range 2,3,4, << this formula removes the last comma to
'give 2,3,4
ActiveCell.Offset(1, 0).Select 'Once the concatenated result is pasted into the cell this moves down to the next cell, e.g. from F1 to F2
x = "" 'The all important, clears x value after finishing concatenation for a range before moving on to another column and range
Next Q 'After one range is done the second column loop kicks in to tell the macro to move to the next column and begin concatenation range again
Terminate: 'error handler
End Sub
#Issun's solution doesn't accept output from a worksheet array formula as the argument for the 'cell_range' parameter. But a slight modification to #Issun's code fixes this. I also added a check that ignores each cell whose value is FALSE.
Function ConcatenateRange( _
ByVal cellArray As Variant, _
Optional ByVal seperator As String _
) As String
Dim cell As Range
Dim newString As String
Dim i As Long, j As Long
For i = 1 To UBound(cellArray, 1)
For j = 1 To UBound(cellArray, 2)
If Len(cellArray(i, j)) <> 0 Then
If (cellArray(i, j) <> False) Then
newString = newString & (seperator & cellArray(i, j))
End If
End If
Next
Next
If Len(newString) <> 0 Then
newString = Right$(newString, (Len(newString) - Len(seperator)))
End If
ConcatenateRange = newString
End Function
For example:
A B (<COL vROW)
------ ------ -----------------
one 1 3
two 1 4
three 2 5
four 2 6
Enter into cell C1 the formula below and press CTRL+ENTER to store the formula as an array formula:
{=ConcatenateRange(IF(B3:B6=1,A3:A6),CHAR(10))}
I was looking further to see if there is a better way of writing concatenate function and found this. It seems that we all have the same working principle for the function. So its ok.
But my function is different that it can take multiple parameters, in combination of ranges, texts and numbers.
I assume that a delimiter is mandatory, so if i don't need it i just put "" as the last parameter).
I also assume that blank cells are not to be skipped. That's the reason why i want the function to take multiple parameters, so i can easily omit those that that i don't want in the concatenation.
Example of use:
=JoinText(A1:D2,F1:I2,K1:L1,";")
You can also use together text and number among the parameters:
=JoinText(A1:D2,123,F1:I2,K1:L1,"PQR",";")
I'd love to hear any comments or suggestions where it can be improved.
Here is the code.
Public Function JoinText(ParamArray Parameters() As Variant) As String
Dim p As Integer, c As Integer, Delim As String
Delim = Parameters(UBound(Parameters))
For p = 0 To UBound(Parameters) - 1
If TypeName(Parameters(p)) = "Range" Then
For c = 1 To Parameters(p).Count
JoinText = JoinText & Delim & Parameters(p)(c)
Next c
Else
JoinText = JoinText & Delim & Parameters(p)
End If
Next p
JoinText = Replace(JoinText, Delim, "", , 1, vbBinaryCompare)
End Function
Function ConcatenateRange to concatenate all cells in range if they are not empty and empty "" string.
Function ConcatenateRange(cellRange As Range, Optional Delimiter As String) As String
Dim cel As Range, conStr As String
conStr = ""
If Delimiter <> "" Then
For Each cel In cellRange
If VarType(cel) <> vbEmpty And Trim(cel) <> "" Then conStr = conStr & cel & Delimiter
Next
ConcatenateRange = Left(conStr, Len(conStr) - Len(Delimiter))
Else
For Each cel In cellRange
If VarType(cel) <> vbEmpty And Trim(cel) <> "" Then conStr = conStr & cel
Next
ConcatenateRange = conStr
End If
End Function
Its very simple brother, Look out of the Excel. No need for all cumbersome formula or VBA.
Just copy all the cells that you need to concatenate and paste it in the notepad. Now just select the space between the lines/columns (it's a TAB space actually) and find and replace it.. Done.. All cells are concatenated. Now just copy and paste it in the column and just verify.. Thats it :) Enjoy.
I suggest you to use Notepad++ for this :) Koodos
Vimarsh
Ph. D. Plant Biotech.
/