This works to put the values in the column:
Sub JR_ArrayToDebugPint2()
' written by Jack in the UK for [url]www.OzGrid.com[/url]
' our web site [url]www.excel-it.com[/url]
' Excel Xp+ 14th Aug 2004
' [url]http://www.ozgrid.com/forum/showthread.php?t=38111[/url]
Dim JR_Values(500)
Dim JR_Count As Integer
Dim R As Long
R = 2
For JR_Count = 1 To 500 Step 1
JR_Values(JR_Count) = Evaluate("=INDEX('Client'!$O$2:$O$347473,MATCH(1,(('Client_Cost'!$D$2:$D$347473=BC" & CStr(R) & ")*('Client_Cost'!$E$2:$E$347473=BE" & CStr(R) & ")),0))")
Sheet1.Range("BG" & CStr(R) & "").Value = JR_Values(JR_Count)
R = R + 1
'Debug.Print JR_Values(JR_Count)
Next JR_Count
End Sub
I've modified the original code I found on mrexcel.com
I get the correct list of values whether I Debug.Print or print to the worksheet. So in my mind, I ought to be able to put the values in an array as they are calculated, then use Range("BG2:BG500").Value = Application.Transpose(myarray).
I am assuming if I do this the values will be placed in the cells in the column all at once, rather than one at a time, which is what this code, and all others I've tried, is doing. I am also assuming that, if the values are placed in the cells in the column all at once, it is MUCH faster than placing the values in the cells one at a time.
What I'm not able to do is get the code to put the value in an array once the formula is evaluated. I've tried variations of the following with no success - statements to set the array and have the array take the value of the calculation are in caps and marked by ==>. The most common error I get is type mismatch.
Sub JR_ArrayToDebugPint2()
Dim JR_Values(500)
Dim JR_Count As Integer
Dim R As Long
==> DIM arrPRICE(0 TO 500) AS VARIANT
R = 2
For JR_Count = 1 To 500 Step 1
JR_Values(JR_Count) = Evaluate("=INDEX('Client'!$O$2:$O$347473,MATCH(1,(('Client_Cost'!$D$2:$D$347473=BC" & CStr(R) & ")*('Client_Cost'!$E$2:$E$347473=BE" & CStr(R) & ")),0))")
==> arrPRICE(R) = JR_VALUES(JR_COUNT)
R = R + 1
'Debug.Print JR_Values(JR_Count)
Next JR_Count
End Sub
When you dimension the variant array like Dim JR_Values(500) you are creating a one-dimensioned array based upon a zero-based index. This first element within the array is JR_Values(0) and the last is JR_Values(500) for a total of 501 array elements. While you could work from 0 to 499 with a little math, you can also force a one-based index on the variant array by declaring it that way.
The assumed worksheet parentage of the BC and BE columns where the individual row data criteria comes from is not definitive when using Application Evaluate like it is when the same formula is used on a worksheet. A worksheet knows who it is; VBA may or may not know what worksheet you are implying.
Sub JR_ArrayToDebugPint2()
Dim olr As Long, rws As Long, JR_Count As Long, JR_Values As Variant
'get some dimensions to the various data ranges
With Worksheets("Client_Cost")
'only use as many rows as absolutely necessary
olr = Application.Min(.Cells(Rows.Count, "C").End(xlUp).Row, _
.Cells(Rows.Count, "E").End(xlUp).Row)
End With
With Worksheets("Client")
rws = Application.Min(.Cells(Rows.Count, "BC").End(xlUp).Row, _
.Cells(Rows.Count, "BE").End(xlUp).Row)
'override the above statement unless you want to run this overnight
rws = 500
End With
ReDim JR_Values(1 To rws) 'force a one-based index on the array
'Debug.Print LBound(JR_Values) & ":" & UBound(JR_Values)
For JR_Count = LBound(JR_Values) To UBound(JR_Values) Step 1
'Debug.Print Evaluate("INDEX('Client'!O2:O" & olr & _
", MATCH(1, (('Client_Cost'!D2:D" & olr & "='Client'!BC" & JR_Count+1 & ")" & _
"*('Client_Cost'!E2:E" & olr & "='Client'!BE" & JR_Count+1 & ")), 0))")
'R would be equal to JR_Count + 1 if R was still used (starts as R = 2)
JR_Values(JR_Count) = _
Evaluate("INDEX('Client'!O2:O" & olr & _
", MATCH(1, (('Client_Cost'!D2:D" & olr & "='Client'!BC" & JR_Count + 1 & ")" & _
"*('Client_Cost'!E2:E" & olr & "='Client'!BE" & JR_Count + 1 & ")), 0))")
'Debug.Print JR_Values(JR_Count)
Next JR_Count
With Worksheets("Client")
.Range("BG2").Resize(UBound(JR_Values), 1) = Application.Transpose(JR_Values)
End With
End Sub
I've left a lot of comments for you to review and subsequently clean up. I recently wrote a narrative of declaring one-dimension and two-dimension variant arrays in How to assign the variable length of an array to integer variable.
Related
I'm trying to update a sheet with information from a filled in previous version.
It is a repeating block which moves down 13 rows eacht time. So trying to loop in combination with copying my selection, since there are only 11 values I need (the 1st and 13th contain information I do not want to overwrite)
The code I use is the following.
Sub Get_Data_From_File()
Dim FileToOpen As Variant, i As Long, KolB As Long, KolG As Long
Dim OpenBook As Workbook
Dim m As Integer, n As Integer
Application.ScreenUpdating = False
FileToOpen = Application.GetOpenFilename(Title:="Select file to import", FileFilter:="Excel Files (*.xls*),*xls*")
If FileToOpen <> False Then
Set OpenBook = Application.Workbooks.Open(FileToOpen)
For i = 1 To 53
m = -8 + i * 13
n = 2 + i * 13
With ActiveSheet
.Blad2.Range("B" & m & ":G" & n).Select
*' .Blad2.Range("B" & CStr(m) & ":G" & CStr(n)).Copy*
ThisWorkbook.Worksheets("blad2").Range("B" & CStr(m) & ":G" & CStr(n)).PasteSpecial xlPasteValues
End With
Next i
OpenBook.Close False
End If
Application.ScreenUpdating = True
End Sub
when I use this, I get a 483 error in the line ".Blad2.Range("B" & CStr(m) & ":G" & CStr(n)).Copy"
so I tried it with the " .Blad2.Range("B" & m & ":G" & n).Select" line
It does not seem to work. If you have any ideas, that would be appreciated.
thanks in advance
I think i've got a good start, but I'm having a tough time taking this to the finish line. Could someone help me out?
I have a name column(G) in my spreadsheet. I want to pull the only the last name out of each cell and assign it to an array called name_array.
I know that my If function is working because if I set each name_cell to the LastName variable it substitutes only the lastname in each cell of the column, but I cannot figure out how to assign that to the array.
Here is my code thus far. Can someone please help me out and point out what I'm missing?
Sub create_namear()
Dim name_array() As Variant
Dim name_range As Range
Dim name_cell As Range
Dim n As Long
Set name_range = ActiveSheet.Range("G2:G" & Range("G" & Rows.Count).End(xlUp).Row)
ReDim name_array(name_range.Cells.Count)
For Each name_cell In name_range.Cells
Dim Lastname As String
If InStr(name_cell, " ") > 0 Then
Lastname = Split(name_cell, " ")(1)
End If
name_array(n) = lastname.value
n = n + 1
Next name_cell
Debug.Print name_array(1)
End Sub
Name Column
Here is another way to achieve what you want without looping. I have commented the code so you should not have a problem understanding it.
BASIC LOGIC
To get the part after SPACE, you can use the formula =IFERROR(MID(G2,SEARCH(" ",G2,1),LEN(G2)-SEARCH(" ",G2,1)+1),"")
Now applying the formula in the entire range and getting the value using INDEX(FORMULA). You can find the explanation of this method in Convert an entire range to uppercase without looping through all the cells
CODE
Option Explicit
Sub Sample()
Dim ws As Worksheet
Dim rng As Range
Dim lRow As Long, i As Long
Dim FinalAr As Variant
'~~> Set this to the relevant sheet
Set ws = Sheet1
With ws
'~~> Find last row in col G
lRow = .Range("G" & .Rows.Count).End(xlUp).Row
'~~> Set your range
Set rng = .Range("G2:G" & lRow)
'~~> Get all the last names from the range and store them
'~~> in an array in 1 go!
FinalAr = Evaluate("index(IFERROR(MID(" & _
rng.Address & _
",SEARCH("" ""," & _
rng.Address & _
",1),LEN(" & _
rng.Address & _
")-SEARCH("" ""," & _
rng.Address & _
",1)+1),""""),)")
End With
'~~> Check the output
For i = LBound(FinalAr) To UBound(FinalAr)
Debug.Print ">"; FinalAr(i, 1)
Next i
End Sub
IN ACTION
ALTERNATIVE METHODS
Use Text To columns and then store the output in an array
Use Flash Fill to get the last names and then store the output in an array. One drawback of this method is that the names which do not have last name, it will show first name instead of a blank.
Sub create_namear()
Dim name_array() As Variant
Dim name_range As Range
Dim name_cell As Range
Dim n As Long
Set name_range = ActiveSheet.Range("G2:G" & Range("G" & Rows.Count).End(xlUp).Row)
ReDim name_array(0 to name_range.Cells.Count-1) '### 0-based array...
For Each name_cell In name_range.Cells
If InStr(name_cell, " ") > 0 Then
name_array(n) = Split(name_cell, " ")(1) 'simplify...
End If
n = n + 1
Next name_cell
Debug.Print name_array(1)
End Sub
Solution using Filter() (values with missing lastnames are excluded):
Sub ExtractLastNames()
Dim arr, name_array, i
arr = WorksheetFunction.Transpose(Range("G2:G" & Cells(Rows.Count, "G").End(xlUp).Row)) 'first, get the horizontal one-dimentional array from cells
name_array = Filter(arr, " ", True) 'second, filter out one-word and empty elements
For i = LBound(name_array) To UBound(name_array)
name_array(i) = Split(name_array(i))(1) 'third, replace name_array values with extracted lastnames
Next
Range("H2").Resize(UBound(name_array) + 1) = WorksheetFunction.Transpose(name_array) ' output
End Sub
Last Names to Array
The following will consider the substring after the last occurring space as the last name.
Option Explicit
Sub create_namear()
Dim ws As Worksheet: Set ws = ActiveSheet
Dim nRange As Range
Set nRange = ws.Range("G2:G" & ws.Range("G" & ws.Rows.Count).End(xlUp).Row)
Dim rCount As Long: rCount = nRange.Rows.Count
Dim nArray() As String: ReDim nArray(0 To rCount - 1)
Dim nCell As Range
Dim n As Long
Dim nmLen As Long
Dim LastSpacePosition As Long
Dim nmString As String
Dim LastName As String
For Each nCell In nRange.Cells
nmString = CStr(nCell.Value)
If InStr(1, nmString, " ") > 0 Then
LastSpacePosition = InStrRev(nCell.Value, " ")
nmLen = Len(nmString)
If LastSpacePosition < nmLen Then
LastName = Right(nmString, nmLen - LastSpacePosition)
nArray(n) = LastName
n = n + 1
End If
End If
Next nCell
If n = 0 Then Exit Sub
If n < rCount Then
ReDim Preserve nArray(0 To n - 1)
End If
Debug.Print "[" & LBound(nArray) & "," & UBound(nArray) & "]" _
& vbLf & Join(nArray, vbLf)
End Sub
Extension on Siddharth' s formula evaluation
These additions to Siddharth's valid code can be helpful, if there are less than 2 data rows in order to avoid
an unwanted evaluation of the title row 1:1 (in case of no data at all, see section 1.b) - This can be prevented by correcting a resulting row number lRow of only 1 to the actual data row start of 2.
Error 9 Subscript out of range (in case of a single element; see section 3.b) - Note that this requires to transform a 1-dim result to a 2-dim results array by means of a adequately dimensioned tmp array.
Furthermore I simplified the formula building to avoid repeated rng.Address insertions just to show another way of doing it (see section 2.).
Sub GetLastName()
'0. Set this to the relevant sheet
Dim ws As Worksheet: Set ws = Sheet1
With ws
'1. Define data range
'1. a) Find last row in col G
Dim lRow As Long
lRow = .Range("G" & .Rows.count).End(xlUp).Row
'1. b) Provide for empty data set ' << Added to avoid title row evaluation
If lRow = 1 Then lRow = 2
'1. c) Set your range
Dim rng As Range: Set rng = .Range("G2:G" & lRow)
'2. Define formula string parts ' << Modified for better readibility
Dim FormulaParts()
FormulaParts = Array("INDEX(IFERROR(MID(", _
",SEARCH("" "",", _
",1),LEN(", _
")-SEARCH("" "",", _
",1)+1),""""),)")
'3. Assign last names to 2-dim array results
'3. a) Get all the last names from the range and store them
Dim results
results = Evaluate(Join(FormulaParts, rng.Address))
End With
'3.b) Provide for single results '<< Added to avoid Error 9 Subscript o/Rng
If UBound(results) = 1 Then '<< Force single element into 2-dim array
Dim tmp(1 To 1, 1 To 1)
tmp(1, 1) = results(1)
results = tmp
End If
'h) Display in VB Editor's immediate window
Dim i As Long
For i = LBound(results) To UBound(results)
Debug.Print ">"; results(i, 1)
Next i
'i) Write last names to target '<< Added to demonstrate writing back
ws.Range("H2").Resize(UBound(results), 1) = results
End Sub
Why does Join() need a double transposition of a 1-dim Long array?
Due to MS Help
the Join() function requires a sourcearray as "one-dimensional array containing substrings to be joined" (btw the help site makes no difference whether it is a Variant or Long).
Note: In the VBE glossary
an array is defined as set of sequentially indexed elements having the same intrinsic data type.
It's no problem to connect 1-dim Variant arrays via Join() and
it's even possible to join numbers as well as they seem to be internally interpreted as "convert us to strings".
Issue with a 1-dim array declared as Long
In some cases I want to restrict the elements type to Long and avoid the Variant solution mentioned above. -
Declaring a "flat" array - here: Numbers() - as Long, however raises Error 5 "Invalid procedure call or argument",
if you try to connect results via a simple
'[2] Failing
Join(Numbers, "|") .
I found an interesting ► work around via a basically redundant double transposition (c.f. [1]),
as it "converts" a flat 1-dim array eventually back to the same dimension.
'[1] work around
Join(Application.Transpose(Application.Transpose(Numbers)), "|")
Question
What's the internal difference how VBA treats both cases and why does Join() need a double transposition of a 1-dim Long array here?
Example call to join a "flat" array declared as Long
In order to show the workaround code line [1] as well as the error raising code line [2],
I integrated a basic error handling showing user defined error lines (ERL), too.
VB Editor's immediate window shows Error 5 in ERL 200:
OK: [1] 3 elems: ~> 100|200|300
ERL: 200 Error No 5 Invalid procedure call or argument
Example call
Sub JoinArr()
Dim Numbers() As Long ' provide for long array Numbers()
FillNumbers 3, Numbers ' call sub procedure to assign 3 numbers to array Nums
' Numbers is now an array of 3 numbers
On Error GoTo oops
'[1] work around - why does Join() need a double transposition in a 1-dim array?
100 Debug.Print " OK: [1] " & UBound(Numbers) & " elems:" & _
" ~> " & Join(Application.Transpose(Application.Transpose(Numbers)), "|")
'[2] join an already existing "flat" array raises Error 5 "Invalid procedure call or argument"
200 Debug.Print " OK [2] " & UBound(Numbers) & " elems:" & _
" ~> " & Join(Numbers, "|")
Exit Sub
oops: Debug.Print "ERL: " & Erl & " Error No " & Err.Number & " " & Err.Description
End Sub
Sub FillNumbers called by above main procedure
Sub FillNumbers(ByVal n As Long, arr)
ReDim arr(1 To n)
arr(1) = 100
arr(2) = 200
arr(3) = 300
End Sub
Trying to Join() an array of Longs will fail:
Sub JoinTestFails()
Dim Numbers(0 To 2) As Long, msg As String
Numbers(0) = 0
Numbers(1) = 1
Numbers(2) = 2
With Application.WorksheetFunction
msg = Join(Numbers, "|")
End With
MsgBox msg
End Sub
The double use of TRANSPOSE() gets around this by generating a one-dimensional, one-based array of Variants:
Sub JoinTest()
Dim Numbers(0 To 2) As Long, msg As String
Numbers(0) = 0
Numbers(1) = 1
Numbers(2) = 2
With Application.WorksheetFunction
Arr = .Transpose(.Transpose(Numbers))
msg = LBound(Arr) & "**" & UBound(Arr) & vbCrLf
msg = msg & Join(.Transpose(.Transpose(Numbers)), "|") & vbCrLf & TypeName(Arr)
End With
MsgBox msg
End Sub
To me, this use of TRANSPOSE is non-intuitive. I would rather make the Variant array with:
Public Function MkVar(arr() As Long) As Variant
' make a variant array from a long array
Dim temp() As Variant, i As Long
ReDim temp(LBound(arr) To UBound(arr))
For i = LBound(arr) To UBound(arr)
temp(i) = arr(i)
Next i
MkVar = temp
End Function
and then:
Sub JoinTest2()
Dim Numbers(0 To 2) As Long, msg As String
Numbers(0) = 0
Numbers(1) = 1
Numbers(2) = 2
arr = MkVar(Numbers)
msg = LBound(arr) & "**" & UBound(arr) & vbCrLf
msg = msg & Join(MkVar(Numbers), "|") & vbCrLf & TypeName(arr)
MsgBox msg
End Sub
I'm looking for a more efficient, less hard-coded way of transposing an array and then autofilling formulas in adjacent columns. Here is my current code for transposing my array in a specific spot on the sheet and autofilling the columns:
If Len(Join(myArray)) > 0 Then
ActiveWorkbook.Sheets("Delta Summary").Range("A3:A" & UBound(myArray) + 2) = WorksheetFunction.Transpose(myArray)
ActiveWorkbook.Sheets("Delta Summary").Range("B3").Select
Range(Selection, Selection.End(xlToRight)).Select
Selection.AutoFill Destination:=Range("B3:K17"), Type:=xlFillDefault
Else: End If
The goal is to transpose the array starting in cell A3 on sheet "Delta Summary". My code accomplishes this, but I'm wondering if there's a better way to do it. For reference, I loop through this array and transpose it several times based on different criteria. I transpose the array beginning at cells A3, A20, A37,..., and A224. Each section has 15 cells allocated for data.
As for the auto-fill, I'd like to auto-fill the formulas in columns B:K down to the last populated cell in column A for that pre-defined range (ex. A3:A17, A20:34, etc.). I don't know how to find the last populated cell for a pre-defined range, so I have this hardcoded.
I'm still learning, so any insight would be greatly appreciated!
Edit: Here is one example of the looping criteria I use to populate my array:
ReDim myArray(0)
For i = 1 To LastCurrID
If ActiveWorkbook.Sheets("Weekly Comparison").Range("N" & i) = "N" And ActiveWorkbook.Sheets("Weekly Comparison").Range("J" & i) = "Billing" Then
myArray(UBound(myArray)) = ActiveWorkbook.Sheets("Weekly Comparison").Range("A" & i)
ReDim Preserve myArray(UBound(myArray) + 1)
End If
Next i
Edit #2: For those who are curious, here's the completed code. I only slightly changed what was commented below.
ReDim myArray(0)
For i = 1 To LastCurrID
If wkb.Sheets("Weekly Comparison").Range("N" & i) = "N" And wkb.Sheets("Weekly Comparison").Range("J" & i) = "Billing" Then
myArray(UBound(myArray)) = wkb.Sheets("Weekly Comparison").Range("A" & i)
ReDim Preserve myArray(UBound(myArray) + 1)
End If
Next i
For y = LBound(myArray) To UBound(myArray)
If Len(Join(myArray)) > 0 Then
With wks
.Range("A" & x & ":A" & UBound(myArray) + x - 1) = WorksheetFunction.Transpose(myArray)
Dim lRow As Long
lRow = .Range("A" & x).End(xlDown).Row - x + 1
.Range("B" & x).Resize(1, 10).AutoFill _
Destination:=.Range("B" & x).Resize(lRow, 10), Type:=xlFillDefault
End With
End If
Next
x = x + 17
EDIT (Based on OP Update Question with Looping)
From the way you build your array, it seems like the array is loading with the last row of the data range to be copied (within the 15 row limit) for each range.
The below will loop through the array again, and will set a factor of 17 to x for each loop (starting at 3) and will find the last row within the specified range starting at 'Bx' and uses the .Resize method to do the AutoFill:
'always best to qualify the workbook, worksheet objects with a variable
Dim wkb As Workbook, wks As Worksheet
Set wkb = Workbooks("myWKb")
Set wks = wkb.Sheets("Delta Summary")
Dim x As Long, y As Long
x = 3
For y = LBound(myArray) To UBound(myArray)
If Len(Join(myArray)) > 0 Then
With wks
.Range("A" & x & ":A" & UBound(myArray) + 2) = WorksheetFunction.Transpose(myArray)
Dim lRow As Long
lRow = .Range("A" & x).End(xlDown).Row
.Range("B" & x).Resize(1, 10).AutoFill _
Destination:=.Range("B" & x).Resize(lRow, 10), Type:=xlFillDefault
End With
End If
x = x + 17
Next
I'm new to VBA in excel, I write code for copying cells from sheet to an array. When I run I got run time error. I don't know whats wrong.
Sub DistSystem()
Dim count As Integer
Dim i As Integer
Dim array_rank() As Variant
Dim array_city() As Variant
Dim array_assign() As Variant
count = Sheets("111").Range("Y2").Value
For i = 0 To count
array_city(i) = Range("A" & i).Value
array_rank(i) = Range("E" & i).Value
array_assign(i) = Range("F" & i).Value
Next
For i = 1 To 10
MsgBox array_rank(i, 1)
Next
End Sub
I suspect you are going to be battle errors in multiple places.
This section of code has 2 significant problems
array_city(i) = Range("A" & i).Value
array_rank(i) = Range("E" & i).Value
array_assign(i) = Range("F" & i).Value
First you are trying to assign values to array that do not have any dimensions. You decleared the arrays but you left them dimensionless. You need to define the dimensions before you try to assign values to the array
Something like
Redim array_city(1 to count)
Next you are trying to get a value from Range("A" & i) when the value of i is zero. Cell "A0" does not exists and will also throw an error.
So to rewrite your code as written, you would need to make a few changes:
Sub DistSystem()
Dim count As Integer
Dim i As Integer
Dim array_rank() As Variant
Dim array_city() As Variant
Dim array_assign() As Variant
count = Sheets("111").Range("Y2").Value
Redim array_rank(1 to count)
Redim array_city(1 to count)
Redim array_assign(1 to count)
For i = LBound(array_rank) To UBound(array_rank)
array_city(i) = Range("A" & i).Value
array_rank(i) = Range("E" & i).Value
array_assign(i) = Range("F" & i).Value
Next
For i = 1 To 10
MsgBox array_rank(i)
Next
End Sub
However, you are over complicating how you are reading the values into the array. You can simply read the entire range directly into the array
Sub DistSystem()
Dim count As Integer
Dim i As Integer
Dim array_rank As Variant 'Notice the arrays are not longer declared with ()
Dim array_city As Variant ' -> this is necessary
Dim array_assign As Variant
count = Sheets("111").Range("Y2").Value
array_city = Range("A1:A" & count).Value
array_rank = Range("E1:E" & count).Value
array_assign = Range("F1:F" & count).Value
For i = 1 To 10
MsgBox array_rank(i, 1)
Next
End Sub
The resulting array with be 2 dimensions, with the Row value as the first dimension and the column as the 2nd dimension. since all of the ranges are a single column, you would access any value by calling array_rank(Row,1) or array_city(Row,1) or array_assign(Row,1).