Excel VBA Appending data to single Array - excel

Am trying to parse an excel file using Excel VBA.
Here is the sample sata
I did some research and found you can assign ranges to array like
Arrayname = Range("A1:D200")
But am looking for some thing more dynamic, like add the below multiple ranges to a single array.
and my final array will be a single array/table with n is number of rows from all ranges and 4 columns.
Can any one please prvide me a example.
Thank you in adavance.

I think you are asking for more information about moving data between ranges and variables so that is the question I will attempt to answer.
Create a new workbook. Leave Sheet1 empty; set cell B3 of Sheet2 to "abc" and set cells C4 to F6 of Sheet3 to ="R"&ROW()&"C"&COLUMN()
Open the VB Editor, create a module and copy the follow code to it. Run macro Demo01().
Option Explicit
Sub Demo01()
Dim ColURV As Long
Dim InxWkSht As Long
Dim RowURV As Long
Dim UsedRangeValue As Variant
' For each worksheet in the workbook
For InxWkSht = 1 To Worksheets.Count
With Worksheets(InxWkSht)
Debug.Print .Name
If .UsedRange Is Nothing Then
Debug.Print " Empty sheet"
Else
Debug.Print " Row range: " & .UsedRange.Row & " to " & _
.UsedRange.Row + .UsedRange.Rows.Count - 1
Debug.Print " Col range: " & .UsedRange.Column & " to " & _
.UsedRange.Column + .UsedRange.Columns.Count - 1
End If
UsedRangeValue = .UsedRange.Value
If IsEmpty(UsedRangeValue) Then
Debug.Print " Empty sheet"
ElseIf VarType(UsedRangeValue) > vbArray Then
' More than one cell used
Debug.Print " Values:"
For RowURV = 1 To UBound(UsedRangeValue, 1)
Debug.Print " ";
For ColURV = 1 To UBound(UsedRangeValue, 2)
Debug.Print " " & UsedRangeValue(RowURV, ColURV);
Next
Debug.Print
Next
Else
' Must be single cell worksheet
Debug.Print " Value = " & UsedRangeValue
End If
End With
Next
End Sub
The following will appear in the Immediate Window:
Sheet1
Row range: 1 to 1
Col range: 1 to 1
Empty sheet
Sheet2
Row range: 3 to 3
Col range: 2 to 2
Value = abc
Sheet3
Row range: 4 to 6
Col range: 3 to 5
Values:
R4C3 R4C4 R4C5
R5C3 R5C4 R5C5
R6C3 R6C4 R6C5
If you work through the macro and study the output you will get an introduction to loading a range to a variant. The points I particularly want you to note are:
The variable to which the range is loaded is of type Variant. I have never tried loading a single range to a Variant array since the result may not be an array. Even if it works, I would find this confusing.
Sheet1 is empty but the used range tells you than cell A1 is used. However, the variant to which I have loaded the sheet is empty.
The variant only becomes an array if the range contains more than one cell. Note: the array will ALWAYS be two dimensional even if the range is a single row or a single column.
The lower bounds of the array are ALWAYS 1.
The column and row dimensions are not standard with the rows as dimension 1 and the columns as dimension 2.
If there is any doubt about the nature of the range being loaded, you must use IsEmpty and VarType to test its nature.
You may also like to look at: https://stackoverflow.com/a/16607070/973283. Skim the explanations of macros Demo01() and Demo02() which are not relevant to you but set the context. Macro Demo03() shows the advanced technique of loading multiple worksheets to a jagged array.
Now create a new worksheet and leave it with the default name of Sheet4.
Add the follow code to the module. Run macro Demo02().
Sub Demo02()
Dim ColOut As Long
Dim OutputValue() As String
Dim Rng As Range
Dim RowOut As Long
Dim Stg As String
ReDim OutputValue(5 To 10, 3 To 6)
For RowOut = LBound(OutputValue, 1) To UBound(OutputValue, 1)
For ColOut = LBound(OutputValue, 2) To UBound(OutputValue, 2)
OutputValue(RowOut, ColOut) = RowOut + ColOut
Next
Next
With Worksheets("Sheet4")
Set Rng = .Range("A1:D6")
End With
Rng.Value = OutputValue
With Worksheets("Sheet4")
Set Rng = .Range(.Cells(8, 2), .Cells(12, 4))
End With
Rng.Value = OutputValue
With Worksheets("Sheet4")
Stg = "C" & 14 & ":G" & 20
Set Rng = .Range(Stg)
End With
Rng.Value = OutputValue
End Sub
Although this macro writes an array to a worksheet, many of the points apply for the opposite direction. The points I particularly want you to note are:
For output, the array does not have to be Variant nor do the lower bounds have to be 1. I have made OutputValue a String array so the values output are strings. Change OutputValue to a Variant array and rerun the macro to see the effect.
I have used three different ways of creating the range to demonstrate some of your choices.
If you specify a range as I have, the worksheet is one of the properties of the range. That is why I can take Rng.Value = OutputValue outside the With ... End With and still have the data written to the correct worksheet.
When copying from a range to a variant, Excel sets the dimensions of the variant as appropriate. When copying from an array to a range, it is your responsibility to get the size of the range correct. With the second range, I lost data. With the third range, I gained N/As.
I hope the above gives you an idea of your options. If I understand your requirement correctly, you will have to:
Load the entire worksheet to Variant
Create a new Array of the appropriate size
Selectively copy data from the Variant to the Array.
Come back withh questions if anything is unclear.

Related

Excel IF Statement Limited

I am using an IF statement in Excel to search for portions of text in the previous column in order to assign a supplier and category to the expense.
Supplier Column
=IF(ISNUMBER(SEARCH("tit",[#Description])),"TITAN",IF(ISNUMBER(SEARCH("Sol",[#Description])),"Soltrack",IF(ISNUMBER(SEARCH("coin",[#Description])),"Coin",IF(ISNUMBER(SEARCH("gree",[#Description])),"Green Dream Projects",IF(ISNUMBER(SEARCH("sars V",[#Description])),"SARS VAT",IF(ISNUMBER(SEARCH("sars p",[#Description])),"SARS PAYE",IF(ISNUMBER(SEARCH("acb",[#Description])),"Debit Order","")))))))
Category Column
the next column then has the following to get the category of the supplier
=IF(ISNUMBER(SEARCH("TITAN",[#Payee])),"Direct Operating Cost",IF(ISNUMBER(SEARCH("Soltrack",[#Payee])),"Direct Operating Cost",IF(ISNUMBER(SEARCH("Coin",[#Payee])),"Direct Operating Cost",IF(ISNUMBER(SEARCH("Green Dream Projects",[#Payee])),"Direct Operating Cost",IF(ISNUMBER(SEARCH("SARS VAT",[#Payee])),"VAT",IF(ISNUMBER(SEARCH("SARS PAYE",[#Payee])),"PAYE",IF(ISNUMBER(SEARCH("Debit Order",[#Payee])),"Debit Order","")))))))
this is working great, but seems i have reached the limit (7) of IF statements I can use in one formula?
I have created the below function to search for text "tit" and if it matches it updates the Payee column.
'excel if range of cells contains specific text vba
Sub MacroToCheckIfRangeOfCellsContainsSpecificText_vba()
Set Rng = Range("B2:B572") ' You can change this
specificText = "*tit*" ' You can change this
For Each Cell In Rng.Cells
If UCase(Cell.Value) Like "*" & UCase(specificText) & "*" Then
Cell.Offset(0, 1) = "Titan"
Else
Cell.Offset(0, 1) = ""
End If
Next
End Sub
Would I need to create a new specificText = "*tit*" for each of the keywords and also a whole section for each of the "For Each" functions?
Dictionary Solution
The first idea is to use a dictionary Replacements and add all the serach/replace pairs there. This has one huge disadvantage. It is against the good practice to not mix logic (code) and data. Good practice would be to put the data not into the code but into a worksheet (see next solution).
Option Explicit
Public Sub MacroToCheckIfRangeOfCellsContainsSpecificText_vba()
Dim RngToCheck As Range
Set RngToCheck = ThisWorkbook.Worksheets("Sheet1").Range("B2:B572") ' specify in which workbook and worksheet
Dim Replacements As Object
Set Replacements = CreateObject("Scripting.Dictionary")
With Replacements
.Add "tit", "Titan"
.Add "sol", "Soltrack"
'add more here
End With
Dim InputValues() As Variant
InputValues = RngToCheck.Value 'read input values into array
Dim OutputValues() As Variant 'create an output array (same size as RngToCheck)
ReDim OutputValues(1 To RngToCheck.Rows.Count, 1 To 1)
Dim iRow As Long
For iRow = 1 To UBound(OutputValues, 1)
Dim Key As Variant
For Each Key In Replacements.Keys
If UCase(InputValues(iRow, 1)) Like "*" & UCase(Key) & "*" Then
OutputValues(iRow, 1) = Replacements(Key)
Exit For 'we don't need to test for the others if we found a key
End If
Next Key
Next iRow
'write output values from array next to input values in the cells
RngToCheck.Offset(ColumnOffset:=1).Value = OutputValues
End Sub
Worksheet Solution
The better solution would be to create a new worksheet Replacements as below:
This can easily be edited by anyone and you don't need to fiddle with the code later if you want to delete or add pairs.
Public Sub ImprovedCheckUsingWorksheet()
Dim RngToCheck As Range
Set RngToCheck = ThisWorkbook.Worksheets("Sheet1").Range("B2:B572") ' specify in which workbook and worksheet
Dim Replacements() As Variant 'read replacements from worksheet
Replacements = ThisWorkbook.Worksheets("Replacements").Range("A2", ThisWorkbook.Worksheets("Replacements").Cells(Rows.Count, "B").End(xlUp)).Value 'read input values into array
Dim InputValues() As Variant
InputValues = RngToCheck.Value 'read input values into array
Dim OutputValues() As Variant 'create an output array (same size as RngToCheck)
ReDim OutputValues(1 To RngToCheck.Rows.Count, 1 To 1)
Dim iRow As Long
For iRow = 1 To UBound(OutputValues, 1)
Dim rRow As Long
For rRow = 1 To UBound(Replacements, 1)
If UCase(InputValues(iRow, 1)) Like "*" & UCase(Replacements(rRow, 1)) & "*" Then
OutputValues(iRow, 1) = Replacements(rRow, 2)
Exit For 'we don't need to test for the others if we found a key
End If
Next rRow
Next iRow
'write output values from array next to input values in the cells
RngToCheck.Offset(ColumnOffset:=1).Value = OutputValues
End Sub
For a 3ʳᵈ column in your replacements worksheet you would need to adjust the following line to be until column "C":
Replacements = ThisWorkbook.Worksheets("Replacements").Range("A2", ThisWorkbook.Worksheets("Replacements").Cells(Rows.Count, "C").End(xlUp)).Value 'read input values into array
and the output values need another column too (second parameter needs to go 1 To 2):
ReDim OutputValues(1 To RngToCheck.Rows.Count, 1 To UBound(Replacements, 2) - 1) 'this works for any amount of columns as it reads the column count from the `Replacements`
the data needs to be written
OutputValues(iRow, 1) = Replacements(rRow, 2) 'first output column
OutputValues(iRow, 2) = Replacements(rRow, 3) 'second output column
and writing the output values needs to be adjusted too:
RngToCheck.Offset(ColumnOffset:=1).Resize(ColumnSize:=UBound(OutputValues, 2)).Value = OutputValues 'this works for any amount of columns as it reads the column count from `OutputValues`
Formula Solution
But if you have your data in a worksheet Replacements like above, and you don't rely an a partial match. Then you don't need VBA and can easily use a formula instead to look it up:
=IFERROR(INDEX(Replacements!B:B,MATCH(B:B,Replacements!A:A,0)),"")

VBA is stepping around my for loop without executing it

I'm trying to make a unique ID for each sample in a variable length data set. to do this I want to use part of two strings of data called the Name and Sample Type. I want i to go down each row in the column and take the pieces of each string and put them together, however when I step through the loop it never goes into my loop, only around it. can someone tell me why?
Sheets("Data").Activate
setlastrow = Sheets("Data").Range("b5000").End(xlUp).Row
setlastcol = Sheets("Data").Cells(5, Columns.Count).End(xlToLeft).Column 'this is still assuming that row 5 has the header in it
colname = Rows(5).Find("Name", LookAt:=xlWhole).Column ' this can be repeated for any other columns we want to asign values to. These variables will make the rest of this much easier
colSampleText = Rows(5).Find("Sample Text", LookAt:=xlWhole).Column
For i = 6 To lastrow
Sheets("Data").Range(Cells(i, 1)) = workbookfunction.if(workbookfunction.CountIf(Range(Cells(6, colname), Cells(i, colname)), Cells(i, colname)) < 10, "0", "") & workbookfunction.CountIf(Range(Cells(6, colname), Cells(i, colname)), Cells(i, colname) & "-" & Left(Cells(i, colSampleText), 5))
'this should find the unique identifying infomation for each sample and analyte
Next i
There are two major errors in your code - plus a minor one. One is structural. You declare non of the variables you use. It's like saying, "Since I don't know how to drive I might as well close my eyes as we speed along". It's not without logic but does little toward getting you to where you want to go.
The other is in the mix-up between the worksheet function you want VBA to execute and the one you wish to assign to a cell to be executed by Excel. Writing a complex formula to a cell is more difficult than getting VBA to calculate a complex formula. For the method, if you want to create a formula in VBA you should assign it to a string first, like MyFormula = "=COUNTIF(D6:D12, "MyName")" and then, after testing it, assign that string to the cell's Formula property, like Cells(R, ClmName).Formula = MyFormula". In the code below I chose to let VBA do the calculating. Since it isn't entirely clear what you want (faulty code is never a good way to show what you intend!) please revise it. It's easier in VBA than in a worksheet function.
Private Sub Test()
Dim LastRow As Long
Dim LastClm As Long
Dim ClmName As Long ' R use "col" for color, "clm" for column
Dim ClmSampleText As Long
Dim CountRng As Range
Dim Output As Variant
Dim R As Long ' R use R for row, C for column
Sheets("Data").Activate
LastRow = Sheets("Data").Range("b5000").End(xlUp).Row
' this is still assuming that row 5 has the header in it
LastClm = Sheets("Data").Cells(5, Columns.Count).End(xlToLeft).Column
' this can be repeated for any other columns we want to asign values to.
' These variables will make the rest of this much easier
ClmName = Rows(5).Find("Name", LookAt:=xlWhole).Column
ClmSampleText = Rows(5).Find("Sample Text", LookAt:=xlWhole).Column
For R = 6 To LastRow
'this should find the unique identifying infomation for each sample and analyte
Set CountRng = Range(Cells(6, ClmName), Cells(R, ClmName))
Output = WorksheetFunction.CountIf(CountRng, Cells(R, ClmName).Value)
If Output < 10 Then Output = 0
Cells(R, 1).Value = CStr(Output) & "-" & Left(Cells(R, ClmSampleText).Value, 5)
Next R
End Sub
The "minor" mistake stems from your lack of understanding of the Cell object. A cell is a Range. It has many properties, like Cell.Row and Cell.Column or Cell.Address, and other properties like Cell.Value or Cell.Formula. The Value property is the default. Therefore Cell is the same as Cell.Value BUT not always. In this example, by not thinking of Cell.Value you also overlooked Cell.Formula, and by placing Cell into a WorksheetFunction you confused VBA as to what you meant, Cell the Value or Cell the Range. With all participants confused the outcome was predictable.
The recommendation is to always write Cell.Value when you mean the cell's value and use Cell alone only if you mean the range.
You have an error with the end part of your For...Next statement.
From the code you have posted, LastRow is not explicitly declared anywhere, so when you run your code, LastRow is created as Type Variant with a default Empty value.
Consider this code:
Sub LoopTest()
Dim DeclaredVariable As Long
Dim i As Long
DeclaredVariable = 10
For i = 1 To UnDeclaredVariable
Debug.Print i & " UnDeclaredVariable"
Next i
For i = 1 To DeclaredVariable
Debug.Print i & " DeclaredVariable"
Next i
End Sub
The output in the immidiate window would be:
1 DeclaredVariable
2 DeclaredVariable
3 DeclaredVariable
4 DeclaredVariable
5 DeclaredVariable
6 DeclaredVariable
7 DeclaredVariable
8 DeclaredVariable
9 DeclaredVariable
10 DeclaredVariable
This shows us that the loop for the UnDeclaredVariable has not been entered - AND this is due to the fact the end part of the For...Next loop is Empty (The default value of a Variant data type) so there is no defined end for the loop to iterate to.
NB To be more precise, the issue is that the UnDeclaredVariable has no (numeric) value assigned to it - if you assign a value to a variable that is undeclared it becomes a data type Variant/<Type of data you assigned to it> for example UnDeclaredVariable = 10 makes it a Variant/Intigertype .
The reason why it steps over the loop and doesn't throw an error is because you don't have Option Explicit at the top of your code module (or Tools > Options > "Require Variable Declaration" checked) which means the code can still run with undeclared variables (this includes if you spell a declared variable incorrectly).
If you add Option Explicit to the top of your code module:
Option Explicit
Sub LoopTest()
Dim DeclaredVariable As Long
Dim i As Long
DeclaredVariable = 10
For i = 1 To UnDeclaredVariable
Debug.Print i & " UnDeclaredVariable"
Next i
For i = 1 To DeclaredVariable
Debug.Print i & " DeclaredVariable"
Next i
End Sub
You would get the following error:
Compile Error:
Variable not defined
This is a fantastic example of why Option Explicit is an important declaration to make in all code modules.
Here is a variation of your code; I've modified your code to set your two columns using Find, loop through each cel in the range(using the current row), set varcnt to count the number of matches, defined the first 5 letters of value in the Sample Text column as str, and used a basic If statement to write the combined the unique ID into the first column.
Dim ws As Worksheet: Set ws = ThisWorkbook.Sheets("Data")
Dim lRow As Long: lRow = ws.Range("b5000").End(xlUp).Row
Dim dataCol As Long: dataCol = ws.Range("A5:J5").Find(What:="Name", LookIn:=xlValues, lookat:=xlWhole).Column
Dim smplTextCol As Long: smplTextCol = ws.Range("A5:J5").Find(What:="Sample Text", LookIn:=xlValues, lookat:=xlWhole).Column
For Each cel In ws.Range(ws.Cells(6, dataCol), ws.Cells(lRow, dataCol))
Dim varcnt As Long: varcnt = Application.WorksheetFunction.CountIf(ws.Range(ws.Cells(6, dataCol), ws.Cells(cel.Row, dataCol)), ws.Cells(cel.Row, dataCol).Value)
Dim str As String: str = Left(ws.Cells(cel.Row, smplTextCol).Value, 5)
If varcnt < "4" Then
ws.Cells(cel.Row, 1).Value = "0" & "-" & str
Else
ws.Cells(cel.Row, 1).Value = "" & "-" & str
End If
Next cel

Copy a set of data multiple times based on criteria on another sheet

Excel 2010. I am trying to write a macro that could copy a set of data multiple times based on criteria on another sheet, but I've been stuck for a long time. I very much appreciate any help that could be offered to help me solve this problem.
Step 1: In the "Criteria" worksheet, there are three columns in which each row contains a specific combination of data. The first set of combination is "USD, Car".
Criteria worksheet
Step 2: Then the macro will move to the Output worksheet (please refer to the below link for screenshots), and then filter column A and B with the first set of criteria "USD" and "Car" in the "Criteria" worksheet.
Step 3: Afterwards, the macro will copy the filtered data into the last blank row. But the tricky part here is that, the filtered data has to be copied two times (as the "Number of set" column in the "Criteria" tab is 3 in this combination, and it doesn't have to copy the data three times since the filtered data would be treated as the first set of data)
Step4: After the filtered data have been copied, the "Set" column D will need to fill in the corresponding number of set that the rows are in. Therefore, in this 1st example, cell D2 and D8 will have "1" value, cell D14-15 will have "2" value, and cell D16-17 will have "3" value.
Step5: The macro will then move back to the "Criteria" worksheet and continue to based on the 2nd set of combination "USD, Plane" to filter the data in the "Output" worksheet. Again, it will copy the filtered data based on the "Number of set" in the "Criteria" worksheet. This process will continue until all the different combinations in the "Criteria" worksheet have been processed.
Output worksheet
Ok sorry for delay, here is a working version
you just have to add a sheet called "BF" because the autofilter count wasn't working properly so I had to use another sheet
Sub testfct()
Dim ShC As Worksheet
Set ShC = ThisWorkbook.Sheets("Criteria")
Dim EndRow As Integer
EndRow = ShC.Cells(Rows.Count, 1).End(xlUp).Row
For i = 2 To EndRow
Get_Filtered ShC.Cells(i, 1), ShC.Cells(i, 2), ShC.Cells(i, 3)
Next i
End Sub
Sub Get_Filtered(ByVal FilterF1 As String, ByVal FilterF2 As String, ByVal NumberSetsDisered As Integer)
Dim NbSet As Integer
NbSet = 0
Dim ShF As Worksheet
Set ShF = ThisWorkbook.Sheets("Output")
Dim ColCr1 As Integer
Dim ColCr2 As Integer
Dim ColRef As Integer
ColCr1 = 1
ColCr2 = 2
ColRef = 4
If ShF.AutoFilterMode = True Then ShF.AutoFilterMode = False
Dim RgTotal As String
RgTotal = "$A$1:$" & ColLet(ShF.Cells(1, Columns.Count).End(xlToLeft).Column) & "$" & ShF.Cells(Rows.Count, 1).End(xlUp).Row
ShF.Range(RgTotal).AutoFilter field:=ColCr1, Criteria1:=FilterF1
ShF.Range(RgTotal).AutoFilter field:=ColCr2, Criteria1:=FilterF2
'Erase Header value, fix? or correct at the end?
ShF.AutoFilter.Range.Columns(ColRef).Value = 1
Sheets("BF").Cells.ClearContents
ShF.AutoFilter.Range.Copy Destination:=Sheets("BF").Cells(1, 1)
Dim RgFilt As String
RgFilt = "$A$2:$B" & Sheets("BF").Cells(Rows.Count, 1).End(xlUp).Row '+ 1
Dim VR As Integer
'Here was the main issue, the value I got with autofilter was not correct and I couldn't figure out why....
'ShF.AutoFilter.Range.SpecialCells(xlCellTypeVisible).Rows.Count
'Changed it to a buffer sheet to have correct value
VR = Sheets("BF").Cells(Rows.Count, 1).End(xlUp).Row - 1
Dim RgDest As String
ShF.AutoFilterMode = False
'Now we need to define Set's number and paste N times
For k = 1 To NumberSetsDisered - 1
'define number set
For j = 1 To VR
ShF.Cells(Rows.Count, 1).End(xlUp).Offset(j, 3) = k + 1
Next j
RgDest = "$A$" & ShF.Cells(Rows.Count, 1).End(xlUp).Row + 1 & ":$B$" & (ShF.Cells(Rows.Count, 1).End(xlUp).Row + VR)
Sheets("BF").Range(RgFilt).Copy Destination:=ShF.Range(RgDest)
Next k
ShF.Cells(1, 4) = "Set"
Sheets("BF").Cells.ClearContents
'ShF.AutoFilterMode = False
End Sub
And the function to get column letter using an integer input :
Function ColLet(x As Integer) As String
With ActiveSheet.Columns(x)
ColLet = Left(.Address(False, False), InStr(.Address(False, False), ":") - 1)
End With
End Function

Selecting random cells and storing them in range variable in excel vba

Sub selecting()
Dim r as Range
Set r = Application.Selection
MsgBox r.Cells(1,1).Address(false,false)
MsgBox r.Cells(1,2).Address(false,false)
MsgBox r.Cells(2,1).Address(false,false)
End Sub
Now the thing is, I select some random cells as irregular range in excel sheet. I get first cell address correct but the next cell address is the cell neighbor to the first one, and not the next cell that I selected.
Basically, I want to collect values from irregular ranges into an array. It would be really helpful if I get addresses of each cell selected in this irregular range.
Simply saying, what I want is if I select cells e1,g4,d7,r1,t3 I should get an array of only these 5 cells in vba program, and this array should have no access to other cells apart from those that were selected.
I am a little unclear on exactly what you are attempting, but I believe this may help you understand the behavior of the script as it's running.
Sub selecting()
Dim myArray(0 To 100, 0 To 1) As Variant
Dim rngSelected As Range
Set rngSelected = Application.Selection
Dim rng As Range
For Each rng In rngSelected
Dim counter As Integer
Debug.Print "The value of cell " & counter & " is " & rng.Value & _
" , and the address is " & rng.Address(False, False)
myArray(counter, 0) = rng.Value
myArray(counter, 1) = rng.Address(False, False)
counter = counter + 1
Next rng
End Sub
Maybe you can tweak this until you get the behavior you are looking for?

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