Create a Range Object from Multiple Areas Items - excel

I have a function that aims to return the visible cells (as a range) after applying an autofilter to an inactive worksheet; the autofilter data is
represented by the range "filteredData" passed to the function. The returned range can then be looped through by the calling code obtaining various
values from the nth row.
I now understand that if the filtered data contains non-contiguous row groupings, only the first group of those rows is returned as a range, using
.SpecialCells(xlCellTypeVisible), and that each of those non-contiguous row groupings is represented by an item, all contained
by the same, single Areas collection - I think.
Is it possible to "convert" those area items into an overall range object? I have tried using the Address property of the item and UNION,
but this only seems to work for the first area item and seems to fail silently when attempting to add a second; no error occurs, but the row count of the
newRange remains unchanged.
Several other scripts are tied into this function and I would like to try to avoid a large re-write.
Any advice would be appreciated.
Thanks
Function getFilteredData(filteredData As Range) As Range
Dim areasData As Range
Dim areaCount As Long
Dim j As Long
Dim areaRg As Range
Dim sheetName As String
Dim newRange As Range
Dim itemAddress AS String
Dim itemRg AS Range
Set areasData = filteredData.Resize(filteredData.Rows.Count - 1, filteredData.Columns.Count).Offset(1).SpecialCells(xlCellTypeVisible)
sheetName = "'" & filteredData.Parent.Name & "'!"
areaCount = areasData.Areas.Count
For j = 1 To areaCount
'unsure if this can be treated as a range...possibly Area object
Set areaRg = areasData.Areas.item(j)
itemAddress = sheetName & areaRg.CurrentRegion.Address
Set itemRg = Range(itemAddress)
If j = 1 Then
Set newRange = itemRg
Else
Set newRange = Union(newRange, itemRg)
End If
Next j
Set getFilteredData = newRange
End Function

Given your use case of looping through the nth row you could use a utility function, e.g.
Function getRangeRowNum(data As Range, num As Long) As Range
If num < 1 Then num = 1
If data.Areas.Count = 1 Then
If num > data.Rows.Count Then
Set getRangeRowNum = data.Rows(data.Rows.Count)
Else
Set getRangeRowNum = data.Rows(num)
End If
Exit Function
End If
Dim i As Long, runRows As Long
For i = 1 To data.Areas.Count
runRows = runRows + data.Areas(i).Rows.Count
If runRows >= num Then Exit For
Next i
If i > data.Areas.Count Then 'Exit For not executed so return last actual row'
Set getRangeRowNum = data.Areas(i - 1).Rows(data.Areas(i - 1).Rows.Count)
Else
Set getRangeRowNum = data.Areas(i).Rows(num - (runRows - data.Areas(i).Rows.Count))
End If
End Function
Sub testFunction()
Dim i As Long, total As Range
Set total = Application.Union(Range("A5:H6"), Range("A9:H12"), Range("A15:H18"))
Debug.Print "Rows property of 'Total' returns " & total.Rows.Count
Debug.Print "Actual number of rows in 'Total' = " & total.Cells.Count / total.Columns.Count
For i = 1 To 10
Debug.Print getRangeRowNum(total, i).Address
Next i
End Sub
If you do intend to continue with filtering ranges though, I think some re-factoring will be inevitable.
An alternative you might consider is to pass an array between your various scripts, since an array is a properly contiguous structure.
Such an array could be constructed from an ADODB.Recordset object, e.g. this video illustrates data being read into one from a closed workbook (although it works just as well for the workbook you have open, provided all changes are saved, since it is the 'disk copy' that is queried).
With this approach you define your filter in SQL (so it could actually be more sophisticated than with AutoFilter), and the filtered results are what are read into the Recordset. The video illustrates getting data 'out of' the RecordSet, but this one shows how you can also transfer it to an array (although you probably will want to use Application.Transpose to have it in the expected form - you should also test thoroughly if you have long ranges, as Transpose didn't always work with more than 65,536 items).
This snippet illustrates how you can also create a RecordSet directly from a range, although I don't know that it's as efficient as the SQL approach. Regardless of how you populate the RecordSet, it has Filter and Sort properties (illustrated in the previous link) such that you can continue to manipulate the data directly in memory before generating the array required.

Related

Return an Array of Only Numbers From a Range With Mixed Datatypes

Related to the following screenshot, the formula
=IF(ISNUMBER($A$1:$A$5),$A$1:$A$5)
will evaluate to the following array
{1;FALSE;2;44644;3}
but I only need it to return the numbers
{1;2;3}
How can this be achieved (getting rid of the dates and booleans)?
Note that ISNUMBER has already gotten rid of error values and whatnot.
Utilization in VBA
Instead of the loop and whatnot in the first procedure I want to simplify by evaluating the correct formula in the second procedure.
Correct
Sub CorrectVBA()
' Result:
' 1
' 2
' 3
Const rgAddress As String = "A1:A5"
Dim ws As Worksheet: Set ws = ThisWorkbook.Worksheets("Sheet1")
Dim rg As Range: Set rg = ws.Range(rgAddress)
Dim Data As Variant: Data = rg.Value
Dim Arr() As Double
Dim Item As Variant
Dim r As Long
Dim n As Long
For r = 1 To UBound(Data, 1)
Item = Data(r, 1)
If WorksheetFunction.IsNumber(Item) Then
If Not IsDate(Item) Then
n = n + 1
ReDim Preserve Arr(1 To n)
Arr(n) = Item
End If
End If
Next r
If n = 0 Then Exit Sub
For n = 1 To UBound(Arr)
Debug.Print Arr(n)
Next n
End Sub
Wrong
Something like this is what I want to do in this particular case.
It is wrong because the formula is wrong.
Sub WrongVBA()
' Result:
' 1
' False
' 2
' 44644
' 3
Const rgAddress As String = "A1:A5"
Dim ws As Worksheet: Set ws = ThisWorkbook.Worksheets("Sheet1")
Dim Data As Variant
Data = ws.Evaluate("IF(ISNUMBER(" & rgAddress & ")," & rgAddress & ")")
Dim r As Long
For r = 1 To UBound(Data, 1)
Debug.Print Data(r, 1)
Next r
End Sub
Final Word
Thank you all.
I have decided to accept objectively JvdV's answer since, if not already, Office 365 is becoming a standard and its new functions make things so much easier.
Personally, the most useful answers were those of T.M. and Ron Rosenfeld.
Also, thanks to Can.U and Domenic.
This is not easy through formulae because Excel can not distinguish between say 44644 being an integer or meant to be a date unless you look at formatting of the cel. The only reasonable way of doing this that I can think of is to use CELL(), as per this older post here on SO. It can't return an array correctly on its own so I came up with the following using BYROW():
Formula in C1:
=FILTER(A1:A5,BYROW(SEQUENCE(5,,0),LAMBDA(a,CELL("format",OFFSET(A1,a,0))="G"))*ISNUMBER(A1:A5))
This would work to filter out the dates (given the format in your data) since the cells that are not formatted as date would return "G" ('General', see the link to the ms-documentation). My limited testing suggested that this would work to filter out dates from the equation as per the question.
Note: To be more specific, you can exclude any cells that have this specific formatting ('mm/dd/yyyy') you have shown, from the equation through:
=FILTER(A1:A5,BYROW(SEQUENCE(5,,0),LAMBDA(a,LEFT(CELL("format",OFFSET(A1,a,0)))<>"D"))*ISNUMBER(A1:A5))
EDIT: The above solution would be ms365 exclusive. For Excel 2019, one way to do this is:
=FILTERXML("<t><s>"&TEXTJOIN("</s><s>",,IF(ISNUMBER(A1:A5),A1:A5,""))&"</s></t>","//s")
It's an CSE-entered formula. If done correctly the returned array would be {1;2;44644;3};
We could also use =FILTERXML("<t><s>"&TEXTJOIN("</s><s>",,A1:A5)&"</s></t>","//s[.*0=0]") however, since TEXTJOIN() has a limit I thought it would be wise to proces any non-number into an empty string beforehand;
There is no way (I can think of) to exclude the dates in this version of Excel.
365
=FILTER(A1:A5,ISNUMBER(-TEXT("1/1/"&A1:A5,"e/m/d")))
or older version:
=N(OFFSET(A1,SMALL(IF(ISNUMBER(-TEXT("1/1/"&A1:A5,"e/m/d")),ROW(1:5)-1),ROW(INDIRECT("1:"&COUNT(-TEXT("1/1/"&A1:A5,"e/m/d"))))),))
Alternative via XML Spreadsheet udf
Though the question shows the excel-formula tag, you might consider to use a user-defined function analyzing the column's Value(xlRangeValueXMLSpreadsheet) or simply Range.Value(11) xml content equivalent.
This approach benefits from the fact that the relevant data types of your question are explicitly distinguished between "Number" and "DateTime" formats.
As the resulting xml content includes namespace definitions like "ss:" I preferred to use late bound MsXml2 for node extraction. - Afaik namespacing can't be applied in FilterXML (a possible work-around would be reduce the whole content via split and replace any namespaces to allow this, too).
The following example udf assumes a 1-column range input (without further error handling) and gets all "real" numbers via a node select Set cells = xDoc.SelectNodes("//ss:Cell[ss:Data/#ss:Type='Number']").
Function Nums(rng As Range)
'[0]Get Value(11)
Dim s As String
s = rng.value(xlRangeValueXMLSpreadsheet) ' or: rng.Value(11)
'[1]Set xml document to memory
Dim xDoc As Object: Set xDoc = CreateObject("MSXML2.DOMDocument.6.0")
'[2]Add namespaces
xDoc.SetProperty "SelectionNamespaces", _
"xmlns:ss='urn:schemas-microsoft-com:office:spreadsheet' " & _
"xmlns:ht='http://www.w3.org/TR/REC-html40'"
'[3]Get cells with Data/#Type "Number"
If xDoc.LoadXML(s) Then ' load wellformed string content
Dim cell As Object, cells As Object
Set cells = xDoc.SelectNodes("//ss:Cell[ss:Data/#ss:Type='Number']") ' XPath using namespace prefixes
Dim tmp(): ReDim tmp(1 To cells.Length, 1 To 1)
For Each cell In cells
Dim i as long: i = i + 1
tmp(i, 1) = cell.Text
Next cell
'[4]return 1-column array
Nums = tmp
End If
End Function
Example call
In tabular Excel e.g. Nums(A1:A5) (resulting in a spill range if you dispose of dynamic array feature, otherwise via CSE), or
via VBA e.g.
Dim rng As Range
Set rng = Sheet1.Range("A1:A5")
Dim results
results = Nums(rng)
rng.Offset(, 1).Resize(UBound(results), 1) = results
As I mentioned in my comments, I don't know of a reliable method of determining if an entry is a date type, since dates in Excel are stored as numbers.
Since you have also written that excluding the dates is not an absolute requirement, here are several formulas that will work depending on your version of Excel.
O365
C1: =FILTER(A1:A5,ISNUMBER(A1:A5))
results will spill down
Earlier versions of Excel
E1: =IFERROR(INDEX($A$1:$A$5,AGGREGATE(15,6,1/ISNUMBER($A$1:$A$5)*ROW(A1:$A$5),ROW(INDEX($A:$A,1):INDEX($A:$A,SUM(--ISNUMBER($A$1:$A$5)))))),"")
entered as an array formula (with ctrl + shift + enter over a range large enough to include all the results)
G1: =IFERROR(INDEX($A$1:$A$5,AGGREGATE(15,6,1/ISNUMBER($A$1:$A$5)*ROW($A$1:$A$5),ROWS($A$1:A1))),"")
entered as a normal formula, then fill down until you start returning blanks

Is it possible to use VBA code on a already filtered sheet?

I have a sheet with about 6000 rows. In my code I first filter out some rows.
Sheets("privata").Rows("2:" & Rows.count).AutoFilter Field:=26, Criteria1:=">=2020-01-30 09:00:00", Operator:=xlAnd, Criteria2:="<=2020-01-30 09:30:00"
Sheets("privata").Rows("2:" & Rows.count).AutoFilter Field:=24, Criteria1:="<>OK"
Sheets("privata").Rows("2:" & Rows.count).AutoFilter Field:=25, Criteria1:="<>SUPPLY_CONTROL,"
Its now down to about 350 rows. After I've filtered it I copy and paste the data to another sheet
Sheets("privata").UsedRange.Copy
Sheets("toptre").Range("A1").PasteSpecial xlPasteAll
After I've copied the data I work on it in various ways in the new sheet.
The entire code takes a while to run. After stepping through the code I discovered that the filtering out process is super quick. What takes time is the pasting of the data in to the other sheet.
Is there a possibility to work with the original filtered sheet? When I try to, it uses all 6000 rows, not just the filtered out ones.
Example of what I want to do:
For i = 2 To RowCount + 1
employee = Sheets("privata").Cells(i, 25)
onList = False
For j = 1 To UBound(employeeList)
If employee = employeeList(j) Then
onList = True
Exit For
End If
Next j
If onList = False Then
countEmployees = countEmployees + 1
employeeList(countEmployees) = employee
End If
If onList = True Then
onList = False
End If
Next i
When referring to Cells(2, 25) I want to refer to the second row in the filtered sheet. Which might be row 3568 in the sheet. Is that possible?
/Jens
After the filtering has been applied, you can make the copy/paste process very fast if you don't use a loop, but use Selection. For example:
Sub TryThis()
Dim r As Range
Sheets("privata").Select
Set r = ActiveSheet.AutoFilter.Range
r.Select
Selection.Copy Sheets("toptre").Range("A1")
End Sub
Usually you want to avoid Selection in VBA. However, you will end up with:
a block of data in sheet "toptre"
the block will include the header row and all visible rows
the block will be just a block (un-filtered)
I am not sure if this will make your process any faster, but it attempts to accomplish what you ask about in your question:
You could use the expression suggested by #GSerg 's comment to create a range object with only the visible rows in the data sheet, e.g.
Dim filteredRange As Range
Set filteredRange = Sheets("privata").UsedRange.Rows.SpecialCells(xlCellTypeVisible)
Assuming there is at least 1 visible row in the sheet (meaning that the above statement will not throw an error), you could then use the following function to access that range as if it were a single, contiguous range:
Function RelativeCell(rng As Range, ByVal row As Long, ByVal col As Long) As Range
Dim areaNum As Long: areaNum = 0
Dim maxRow As Long: maxRow = 0
Dim areaCount As Long: areaCount = rng.Areas.Count
Do While maxRow < row
areaNum = areaNum + 1
If areaNum > areaCount Then
Set RelativeCell = Nothing
Exit Function
End If
maxRow = maxRow + rng.Areas(areaNum).Rows.Count
Loop
Dim lastArea As Range: Set lastArea = rng.Areas(areaNum)
Set RelativeCell = lastArea.Cells(row - (maxRow - lastArea.Rows.Count), col)
End Function
To print all the filtered values in column B, for example, you could use the above method on the filteredRange object (set earlier) this way:
Dim r As Long: r = 1
Do
Dim cell As Range: Set cell = RelativeCell(filteredRange, r, 2)
If cell Is Nothing Then Exit Do
Debug.Print cell.Value
r = r + 1
Loop
To simplify the above code, you could also use a function to know the last relative row number in the filtered range using the following function:
Function RelativeCellLastRow(rng As Range) As Long
Dim r As Long: r = 0
Dim i As Long
For i = 1 To rng.Areas.Count
r = r + rng.Areas(i).Rows.Count
Next
RelativeCellLastRow = r
End Function
Then, the code to print all the filtered values in column B would be reduced to this:
Dim r As Long
For r = 1 To RelativeCellLastRow(filteredRange)
Debug.Print RelativeCell(testRng, r, 2).Value
Next
If you use RelativeCellLastRow, it would be good to ensure that it is only executed once, to avoid unnecessary recalculations. In the For loop above, it is only executed once, since VBA only executes the limits of a For loop before the first iteration. If you need the value several times, you can store it in a variable and use the variable instead.
The idea behind the RelativeCell function is that the range returned by the call to SpecialCells is a multi-area range, i.e. a range made up of several non-contiguous ranges. What relativeCell does is to skip through the non-contiguous areas until it finds the row number it is looking for. If the row number is beyond the total number of rows in the range, the function returns Nothing, so the calling code must be aware of this to avoid calling a method or property on Nothing.
It is also worth nothing that RelativeCell works on a range with hidden rows, not hidden columns. With hidden columns, the code becomes a little more complex, but the complexity can be encapsulated in the RelativeCell function without affecting the code that uses the function.
Again, I am not sure whether this will make your code faster. When I did some tests to emulate your scenario using a sheet with 6000+ rows and 30 columns of random strings, the copy/paste after the filtering ran very quickly, but it could be because of the machine I am using, the version of Excel that I am using (2016), or the data I used. Having said that, I hope the above code is of some help.

VBA Macro to find rows and store in array runs slow

So I made a simple VBA macro to run over ~7000 rows of data - the idea is that .Find finds the cells which contain "1" in column G, so that it can store the row number in an array which I shall later throw back to another sub
Unfortunately the code takes too long to run - it begs the question, have I created an infinite loop in my code? Or is asking it to loop a .find operation over 7000 cells too much for vba to handle at a reasonable speed? (i.e. do I need to improve efficiency in areas?)
Option Explicit
Public Sub splittest()
Dim sheet As Object, wb As Workbook
Dim rangeofvals As Range
Dim pullrange As Variant
Dim c As Long
Dim dynarr() As Variant
Dim xvalue As Long
Dim firstaddress As Variant
Dim count As Long
Set wb = ThisWorkbook
Set sheet = wb.Sheets("imported d")
Set rangeofvals = Range("G1:G6939")
'need to set pull range at some later point
Call OptimizeCode_Begin 'sub which turns off processes like application screen updating
xvalue = 1
ReDim dynarr(3477) 'hardcoded, replace with a countif function at some point
count = 0
With wb.Sheets("imported d").Range("G1:G6939")
c = rangeofvals.Find(xvalue, LookIn:=xlFormulas).Row
If c >= 0 Then
dynarr(count) = c
' MsgBox firstaddress
Do
' MsgBox c
c = rangeofvals.FindNext(Cells(c, 7)).Row
dynarr(count) = c 'apparently redim preserve would be slower
Loop While c >= 0
End If
Call OptimizeCode_End 'sub which turns back on processes switched off before
End With
End Sub
If you know the column is G and all the data is contiguous, then just loop through the rows and check the cell value directly:
Dim rows As New Collection
Dim sheet As Worksheet
Dim lastRow, i As Integer
Set sheet = ThisWorkbook.Sheets("imported d")
lastRow = sheet.Cells(1,7).CurrentRegion.Rows.Count
For i = 1 to lastRow
If (sheet.Cells(i,7).Value = 1) Then
rows.Add i
End If
Next
Unclear how the data is being used in the other sub but collection is definitely more efficient storage object for adding iteratively when the total item count is indeterminate. If you want to convert to an array then you can do so efficiently afterward since the collection tells you the item count. I'm not really sure why you would need an array specifically but I'm not going to tell you not to without seeing the client sub. Also note that the declaration of sheet was changed from Object to Worksheet since it is better to use the specific data type if possible.
...yep it was an infinite loop.
the line:
Loop While c >= 0
caused it as there is never an occasion c is less than 0 - back to the drawing board for me!

Returning unique value and avoid looping through an unfiltered range

First post on here, so I hope I'm clear enough.
I have a table on a worksheet that I am working with. I've passed the listObject to a class, which can return various bits of data from it. I'd like to retrieve a unique list, by filtering against a specified column heading.
My question is this:
Can I return a range containing all the rows, once filtered, without looping through the entire, unfiltered range manually?
My current code loops through the (unfiltered) range, looking for unique entries as below. It's taking a noticeable amount of time on my test worksheet, so don't think it'll be viable for the operational example.
Public Function returnUniqueList(col As String) As Collection
' get unqiue lists from the table. Useful for things like LCPs or ballast types
' returns as list of strings
Dim i As Integer
Dim r As Excel.Range
Dim reqCol As Integer
Dim tempString As String
' collection of strings with the unique values
Dim retString As New Collection
reqCol = returnColId(col)
On Error GoTo errorCatch
' collect the unique values
For Each r In pLO.Range.rows
If Not InCollection(retString, r.Cells(1, reqCol)) Then
' add to the collection, including the key
If r.Cells(1, reqCol) <> "" Then
retString.Add r.Cells(1, reqCol), r.Cells(1, reqCol)
End If
End If
Next r
Set returnUniqueList = retString
Exit Function
errorCatch:
MsgBox "Error returning unique list: " + Err.Description
End Function
So after some messing around with various in-built excel/VBA functionality, I've settled on advanced filters. One of the issues I had, was that while I filtered on one column, I wanted to return the filtered table to the calling piece of code. The above function now looks like this:
Public Function returnUniqueList(col As String, searchTerm As String) As Excel.range
' get unique lists from the table. Useful for things like LCPs or ballast types
' returns as excel.range
Dim reqCol As Integer
On Error GoTo errorCatch
reqCol = returnColId(col)
Dim critRange As String
Dim cr As Excel.range
critRange = "=""=" + searchTerm + "*"""
pWkSht.Cells(1, 1000) = col
pWkSht.Cells(2, 1000) = critRange
Set cr = pWkSht.range(pWkSht.Cells(1, 1000), pWkSht.Cells(2, 1000))
' filter for unique entries on this column
pLO.range.Columns(reqCol).Select
pLO.range.Columns(reqCol).AdvancedFilter Action:=xlFilterInPlace, Unique:=True, CriteriaRange:=cr
Set returnUniqueList = pLO.range.SpecialCells(xlCellTypeVisible).EntireRow
pWkSht.Cells(1, 1000) = Empty
pWkSht.Cells(2, 1000) = Empty
Exit Function
errorCatch:
MsgBox "Error returning unique list: " + Err.Description
End Function
The tricky thing I found was then working on the range in the calling function. I found that excel ranges can contain 'areas'. This is due to the way excel works with contiguous data. So in the calling function, I had to iterate through the areas in the returned ranges. This does add a level of overhead into the original calling function that I had hoped to avoid (I wanted to return a single range, with a single area that could easily be iterated through).
The most reliable method I found of iterating through the range/areas returned from the above is based around this snippet, which I use in loads of places in one fashion or another (different columns being pulled from the table, etc:
Set devices = edh.returnUniqueList("DaliCct", lcp)
' filter by the requested LCP
'clear down the dali ccts box
daliCctsListBox.Clear
' cycle through the returned areas, retrieving the relvant info
For i = 1 To devices.Areas.Count
For rowInd = 1 To devices.Areas(i).rows.Count
Dim r As Excel.range
For Each r In devices.Areas(i).rows(rowInd)
If (r.Cells(daliCctColId) <> "") And (r.Cells(daliCctColId) <> "DaliCct") Then
daliCctsListBox.AddItem r.Cells(daliCctColId)
bAdded = True
End If
Next r
Next rowInd
Next i

excel vba how to copy the value of multiple non-contiguous ranges into an array

I am trying to copy the value of multiple non-contiguous ranges into an array. I wrote code like this:
summaryTempArray = .range("A2:D9,A11:D12,A14:D15").Value
But it copies only the first part (A2:D9). Then, I tried the following and I get the error - "Method Union of Object _Global Failed" - is there any mistake in the way that I am using union?
summaryTempArray = Union(.range("A2:D9"), .range("A11:D12"), .range("A14:D15")).Value
Don't know what was wrong with your union, but it would have created the same range, which you stated in your first attempt.
The problem is, you have now multiple areas. Which you can, and as far as I know, has to address now.
Here is an example, which will resolve in an array of all areas, without adding each cell individually, but adding each area individually to the summary array:
Public Sub demo()
Dim summaryTempArray() As Variant
Dim i As Long
With Tabelle1
ReDim summaryTempArray(1 To .Range("A2:D9,A11:D12,A14:D15").Areas.Count)
For i = 1 To .Range("A2:D9,A11:D12,A14:D15").Areas.Count
summaryTempArray(i) = .Range("A2:D9,A11:D12,A14:D15").Areas(i)
Next i
End With
End Sub
Hope this helps.
I believe Jook's solution is as good as you are going to get if it is important to get the source ranges into an array. However, I think the solution should include instructions on extracting values from a ragged array. This is not difficult but the syntax is obscure.
I cannot get your Union statement to fail either. I assume there is something about the context that causes the failure which I cannot duplicate.
The code below shows that the two ranges are the same and that only the first sub-range is loaded to an array as you reported. It finishes with an alternative approach that might be satisfactory.
Option Explicit
Sub Test()
Dim CellValue() As Variant
Dim rng As Range
With Worksheets("Sheet1")
Set rng = .Range("A2:D9,A11:D12,A14:D15")
Debug.Print rng.Address
Set rng = Union(.Range("A2:D9"), .Range("A11:D12"), .Range("A14:D15"))
Debug.Print rng.Address
' The above debug statements show the two ranges are the same.
Debug.Print "Row count " & rng.Rows.Count
Debug.Print "Col count " & rng.Columns.Count
' These debug statements show that only the first sub-range is included the
' range counts.
CellValue = rng.Value
Debug.Print "Rows " & LBound(CellValue, 1) & " to " & UBound(CellValue, 1)
Debug.Print "Cols " & LBound(CellValue, 2) & " to " & UBound(CellValue, 2)
' As you reported only the first range is copied to the array.
rng.Copy Destination:=Worksheets("Sheet2").Range("A1")
' This shows you can copy the selected sub-ranges. If you can copy the
' required data straight to the desired destination, this might be a
' solution.
End With
End Sub
I had the same problem & tried a few methods without success until I hit on this:-
dim i as integer
Dim rng1 as range
Dim str as string
dim cels() as string
Set rng1 = sheet1.Range("A2:D9,A11:D12,A14:D15")
str = rng1.address(0,0)
cels() = split(str, ",") '<--- seems to work OK
for i = 0 to 2
Debug.Print cels(i)
Next i
I would be interested if this is an "incorrect" conversion method.
It is possible to create a multi dimensional array from non concurrent cell ranges. What I did was use a bit of the code above for the range copy mechanic I learned 2 things; that with that method you can refer to the actual cells and not just the data and you can also move and preserve order with it. In my personal project we have to use some excel files to fill out calibration data. It runs the calculations and produces a report of calibration record for our files to refer to later. These stock files are boring! I wanted to spruce it up a bit and color most of the documents empty cells depending on if the calibration passed or not. The files separate the individual check steps so the ranges I wanted to look through were not always adjacent. What I came up with is to use the copy function below to create a new sheet and paste all the non-concurrent ranges into one nice new set of concurrent ones and then have my array look at the new sheet to draw my table. I have it run the lookup I needed and then get rid of the now useless sheet.
Public Sub ColorMeCrazy()
' First Declare your variables that you will need line notes will be added to all the ones for just the array problem
Dim chkarray As Variant
Dim i As Integer ' for the array lookup loop
Dim j As Integer ' also for the array lookup loop
Dim chk1 As Boolean
Dim chk2 As Boolean
Dim cpyrange As Range ' the non-concurrent range collector haha.
Dim cz As Range
chk2 = True
Set cz = Worksheets("AN_PRM-36").Range("A1:I1,C2:I2,I3:I35,A30:H32,D33:H35,C34:C35,A36:E36,A22:H23,D24:H24,A16:H16,A8:H9,D10:H10")
' the next item below sets the ranges i wish to use. see that they arent all just right next to eachother.
Set cpyrange = Worksheets("AN_PRM-36").Range("G7:H7,G15:H15,G21:H21,G28:H29")
' this is the new sheet i made to create the array with
Sheets.Add.Name = "AN_PRM-36tmp"
' the data gets coppied to the new sheet but now its all together
cpyrange.Copy Destination:=Worksheets("AN_PRM-36tmp").Range("A1")
' now i tell the array i want it to use the data on the new sheet
chkarray = Worksheets("AN_PRM-36tmp").Range("A1:B5")
'this was my look up for the nonsense that i wanted to do later
For i = LBound(chkarray, 1) To UBound(chkarray, 1)
For j = LBound(chkarray, 2) To UBound(chkarray, 2)
Debug.Print chkarray(i, j)
If chkarray(i, j) = "Pass" Then
chk1 = True
Else
chk2 = False
End If
Next
Next
If chk1 = True And chk2 = True Then
cz.Interior.ColorIndex = 4
Else
cz.Interior.ColorIndex = 3
End If
' this last bit will get rid of the new sheet and not ask you are you sure you want it gone.
Application.DisplayAlerts = False
Sheets("AN_PRM-36tmp").Delete
Application.DisplayAlerts = True
End Sub

Resources