I'm trying to assign a 2D array of size 183x6 to a new sheet, populating the blank cells from A1:G182 with the values of the array. For reference, my array is called "Directory" and the empty sheet I want to populate is called "List".
I've tried two different approaches, one by explicitly assigning the specified range to the array as such:
Worksheets("List").Range(Cells(1,1), Cells(UBound(Directory, 1) + 1, UBound(Directory, 2) + 1)) = Directory
And also by trying to iterate through each entry in the array:
For i = 0 To UBound(Directory, 1)
For j = 0 To UBound(Directory, 2)
Worksheets("List").Range(Cells(i + 1, j + 1), Cells(i + 1, j + 1)) = Directory(i,j)
Next j
Next i
In both cases, I get the error:
Run-time error '1004':
Application-defined or object defined error.
Any ideas what could be happening? I appreciate your help.
Try:
Worksheets("List").Range("A1").Resize(UBound(Directory, 1) + 1, UBound(Directory, 2) + 1).Value = Directory
Or:
For i = 0 To UBound(Directory, 1)
For j = 0 To UBound(Directory, 2)
Worksheets("List").Range(Worksheets("List").Cells(i + 1, j + 1), Worksheets("List").Cells(i + 1, j + 1)) = Directory(i,j)
Next j
Next i
You don't need any loops to move an array to memory. For example:
Sub Array2Range()
Dim Directory(1 To 182, 1 To 6) As Variant
Dim rng As Range, i As Long, j As Long
For i = 1 To 6
For j = 1 To 182
Directory(j, i) = i * j
Next j
Next i
Set rng = Sheets("List").Range("A1:F182")
rng = Directory
End Sub
will produce:
Related
I have an array full of data that I want to write in a worksheet.
I obtain 2 differents results while doing this :
1) Looping through indexes
For i = 0 To UBound(dataarray(), 1)
For j = 0 To UBound(dataarray(), 2)
With mWS_data
.Cells(i + 2, j + 1) = dataarray(i, j)
End With
Next j
Next i
2) Filling the range directly
With mWS_data
'Row + 2 because datarray starts from 0, and 1st row is titles, Column + 1 because same reason but no titles
.Range(.Cells(2, 1), .Cells(UBound(dataarray(), 1) + 2, UBound(dataarray(), 2) + 1)) = dataarray()
End With
With the same data, in the first case I have all the data in the worksheet (correct result) and in the second case, I only have few datas (all the correct info of one column in the middle, and 1 cell with correct info on an other column).
My code was working perfectly fine last friday, there was absolutly no change in the code and today it is not working correctly.
I am use to code the second way because of much faster processing time.
Is it possible that an excel setup interfer somehow ?
Or did I wrote somehting wrong ?
--- EDIT : ---
Here is the full code with the simplifications you gave me
Sub Load()
Dim dataArray() As Variant
Dim i As Long
Dim j As Long
Dim c_attribute As New Cls_attribute
ReDim dataArray(mJobs.Count - 1, attributes.Count - 1)
'Turns off screen updating and auto calculation
DisplayCalculation False
'For each item into collection
For i = 1 To mJobs.Count
Index = i
'Get data from its variable name
For j = 1 To attributes.Count
Set c_attribute = attributes.Item(j)
On Error Resume Next
dataArray(i - 1, j - 1) = CallByName(Me, c_attribute.name, VbGet)
On Error GoTo 0
Set c_attribute = Nothing
Next j
Next i
With mWS_data
'Remove previous data
.Rows("2:" & Rows.Count).Delete
'Data to worksheet '[VERSION THAT WORKS]
For i = 0 To UBound(dataArray, 1)
For j = 0 To UBound(dataArray, 2)
.Cells(i + 2, j + 1) = dataArray(i, j)
Next j
Next i
'Data to worksheet '[VERSION THAT FAILS]
'.Range("A2").Resize(UBound(dataArray, 1) + 1, UBound(dataArray, 2) + 1).Value = dataArray
End With
'Turns in screen updating and auto calculation
DisplayCalculation True
End Sub
Though I can not show you the data because it is confidential and not GDPR compliant :
When it works : 56 rows and 68 columns of datas complete
When it fails : same range is filled, but only "AG" column and "AH44" cell contain datas.
Write a 2D Zero-Based Array to a Worksheet
Option Explicit
Sub WriteArrayToWorksheet()
Dim DataArray As Variant: ReDim DataArray(0 To 4, 0 To 9) ' 5*10, 'A2:J6'
Dim r As Long
Dim c As Long
For r = 0 To 4
For c = 0 To 9
DataArray(r, c) = (r + 1) * (c + 1)
Next c
Next r
' Remember: 'UBound(DataArray, 1)', 'UBound(DataArray,2)', 'DataArray'.
' Correct: .Range(.Cells(2, 1), .Cells(UBound(DataArray, 1) + 2, UBound(DataArray, 2) + 1)).Value = DataArray
' Wrong: .Range(.Cells(2, 1), .Cells(UBound(DataArray(), 1) + 2, UBound(DataArray(), 2) + 1)) = DataArray()
With mWS_data
' Row + 2 because DataArray starts from 0, and 1st row is titles, Column + 1 because same reason but no titles
' Correct:
.Range(.Cells(2, 1), .Cells(UBound(DataArray, 1) + 2, UBound(DataArray, 2) + 1)).Value = DataArray
' I prefer using 'Resize':
'.Range("A2").Resize(UBound(DataArray, 1) + 1, UBound(DataArray, 2) + 1).Value = DataArray
End With
End Sub
I have a one-dimension array generated by a listbox of strings I would like to use to match with master 2D array with strings in the first column and numbers in all others. The objective is to create a third array with matching strings and the relevant data from the master. Could not find a better solution from searching here although the subjected is not unknown. Guess I am lost in building the new array.
Private Sub ImportSelection()
Dim i, j, k, m, ListSize As Integer
Dim arr2() As String
Dim pArr As variant
Dim Size As Integer
Size = List2.ListCount
ReDim ListBoxContents(0 To Size) As String
For i = 1 To Size
ListBoxContents(i) = List2.list(i)
Next i
On Error GoTo eh
ReDim arr2(1 To List2.ListCount, 1 To 16)
For i = LBound(ListBoxContents) To UBound(ListBoxContents)
For j = LBound(pArr, 1) To UBound(pArr, 1)
If ListBoxContents(i) = pArr(i, 1) Then
arr2(k, m) = pArr(i, j)
k = k + 1
m = m + 1
End If
Next j
Next i
eh:
MsgBox Err.Description
End Sub
Change the middle part of the code to be -->
k = 0 ' need to initialize (and also add headings to row zero)
For i = LBound(ListBoxContents) To UBound(ListBoxContents)
For j = LBound(pArr, 1) To UBound(pArr, 1)
If ListBoxContents(i) = pArr(J, 1) Then ' pArr needs to be J
k = k + 1 ' got a match, ergo increment the output row
For m = 0 To UBound(pArr, 2) - 1
arr2(k, m) = pArr(J, m) ' move into col m, from pArr J row
Next m
End If
Next j
Next i
Exit Sub ' do not drop thru
Also as Comintern sez --> pArr is never assigned a value.
Also, are you getting what you want from
Dim i, j, k, m, ListSize As Integer
I have a simple excel UDF for converting an array of mass values to mol fractions. Most times, the output will be a column array (n rows by 1 column).
How, from within the VBA environment, do I determine the dimensions of the target cells on the worksheet to ensure that it should be returned as n rows by 1 column versus n columns by 1 row?
Function molPct(chemsAndMassPctsRng As Range)
Dim chemsRng As Range
Dim massPctsRng As Range
Dim molarMasses()
Dim molPcts()
Set chemsRng = chemsAndMassPctsRng.Columns(1)
Set massPctsRng = chemsAndMassPctsRng.Columns(2)
chems = oneDimArrayZeroBasedFromRange(chemsRng)
massPcts = oneDimArrayZeroBasedFromRange(massPctsRng)
'oneDimArrayZeroBasedFromRange is a UDF to return a zero-based array from a range.
ReDim molarMasses(UBound(chems))
ReDim molPcts(UBound(chems))
totMolarMass = 0
For chemNo = LBound(chems) To UBound(chems)
molarMasses(chemNo) = massPcts(chemNo) / mw(chems(chemNo))
totMolarMass = totMolarMass + molarMasses(chemNo)
Next chemNo
For chemNo = LBound(chems) To UBound(chems)
molPcts(chemNo) = Round(molarMasses(chemNo) / totMolarMass, 2)
Next chemNo
molPct = Application.WorksheetFunction.Transpose(molPcts)
End Function
I understand that, if nothing else, I could have an input parameter to flag if return should be as a row array. I'm hoping to not go that route.
Here is a small example of a UDF() that:
accepts a variable number of input ranges
extracts the unique values in those ranges
creates a suitable output array (column,row, or block)
dumps the unique values to the area
Public Function ExtractUniques(ParamArray Rng()) As Variant
Dim i As Long, r As Range, c As Collection, OutPut
Dim rr As Range, k As Long, j As Long
Set c = New Collection
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'
' First grab all the data and make a Collection of uniques
'
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
On Error Resume Next
For i = LBound(Rng) To UBound(Rng)
Set r = Rng(i)
For Each rr In r
c.Add rr.Value, CStr(rr.Value)
Next rr
Next i
On Error GoTo 0
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'
' next create an output array the same size and shape
' as the worksheet output area
'
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
k = 1
With Application.Caller
ReDim OutPut(1 To .Rows.Count, 1 To .Columns.Count)
End With
For i = LBound(OutPut, 1) To UBound(OutPut, 1)
For j = LBound(OutPut, 2) To UBound(OutPut, 2)
If k < c.Count + 1 Then
OutPut(i, j) = c.Item(k)
k = k + 1
Else
OutPut(i, j) = ""
End If
Next j
Next i
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'
' put the data on the sheet
'
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
ExtractUniques = OutPut
End Function
You should return two dimensional arrays: n × 1 for row and 1 × n for column vectors.
So you need either
Redim molPcts(1, Ubound(chems) + 1)
or
Redim molPcts(Ubound(chems) + 1, 1)
To refer to them, you need to use both indices:
molPcts(1, chemNo + 1)
or
molPcts(chemNo + 1, 1)
If you prefer 0-based arrays, the redim should be like this:
Redim molPcts(0 To 0, 0 To Ubound(chems))
Redim molPcts(0 To Ubound(chems), 0 To 0)
I have a 2-dimensional range (i, j) like this:
1 2 3 4 5
6 7 8 9 0
I want to copy&paste it to another sheet like this:
1 6 2 7 3 8 4 9 5 0
I need to recalculate the 2-dim range many times and store the results on another sheet, where each row stores one iteration.
Right now I store all calculations in a array (N, i*j) using two for-loops and then paste all itearations on another sheet.
Is there a faster way to do that?
Current code:
Dim a(1 To 100, 1 To 10) As Double
For iter = 1 To 100
Calculate
For i = 1 To 2
For j = 1 To 5
a(iter, i + j * (i - 1)) = Cells(i, j)
Next j
Next i
Next iter
With Sheets("results")
Range(.Cells(1, 1), .Cells(100, 2 * 5)) = a
End With
UPD:
After each "calculate" the values of the initial range change. The example just illustrates how the values from 2-d range should be stored in one row.
UPD2:
Corrected my current code
Something like this should work for you:
Sub tgr()
Dim rData As Range
Dim iter As Long
Dim lNumIterations As Long
Dim i As Long, j As Long, k As Long
Dim a() As Double
Dim aAfterCalc As Variant
Set rData = Sheets("Data").Range("A1:E2")
lNumIterations = 100
ReDim a(1 To lNumIterations, 1 To rData.Rows.Count * rData.Columns.Count)
For iter = 1 To lNumIterations
k = 0
Calculate
aAfterCalc = rData.Value
For j = 1 To rData.Columns.Count
For i = 1 To rData.Rows.Count
k = k + 1
a(iter, k) = aAfterCalc(i, j)
Next i
Next j
Next iter
Sheets("results").Range("A1").Resize(lNumIterations, UBound(a, 2)).Value = a
End Sub
Try this. It gives your desired output and only uses two loops (instead of three)
' For loop
Dim i As Long, j As Long
' Initalise array
Dim tmp(1 To 100, 1 To 10) As Variant
'Loop through all rows in already initalised array
For i = LBound(tmp, 1) To UBound(tmp, 1)
'Calculate to get updated row contents
Calculate
'Loop through each column in row
'The Round and divided by two is to calculate the number of columns concerned instead of the number in the array
For j = LBound(tmp, 2) To Round((UBound(tmp, 2) + 0.1) / 2)
'First row
tmp(i, (j + j - 1)) = Cells(1, j).Value2
'Second row
' If incase the array is initalised to an odd number otherwise this would be out of range
If j * 2 <= UBound(tmp, 2) Then
tmp(i, j * 2) = Cells(2, j).Value2
End If
Next j
Next i
' Write back to sheet
With Sheets("results").Cells(1, 1)
Range(.Offset(0, 0), .Offset(UBound(tmp, 1) - 1, UBound(tmp, 2) - 1)) = tmp
End With
Not sure I get you, but something like this
Sub test()
Dim a() As Variant
Dim b() As Variant
a = Range("a1:e1").Value
b = Range("a2:e2").Value
For x = 1 To 5
Range("H1").Offset(0, x).Value = a(1, x)
Range("H1").Offset(0, 5 + x).Value = b(1, x)
Next x
End Sub
Private Sub this()
Dim this As Variant, counter As Long, that As Integer, arr() As Variant
counter = 0
this = ThisWorkbook.Sheets("Sheet3").UsedRange
For i = LBound(this, 2) To UBound(this, 2)
counter = counter + 2
ReDim Preserve arr(1 To 1, 1 To counter)
arr(1, counter - 1) = this(1, i)
arr(1, counter) = this(2, i)
Next i
ThisWorkbook.Sheets("Sheet4").Range(ThisWorkbook.Sheets("Sheet4").Cells(1, 1), ThisWorkbook.Sheets("Sheet4").Cells(1, counter)).Value2 = arr
End Sub
I have two functions in VBA. Function1 returns a 1D array. Then I have function2 which is a multidimensional array. I would like to copy the array in Function1 to the columns of the multidimensional array starting at index 1.
arr2(0,0) = "Something"
arr2(0,1) = ("Something",arr1(0))
arr2(0,2) = ("Something",arr1(1))
This is what I have. arr1 is GetRecData and arr2 is AllChannelsData.
For i = 0 To UBound(channelList)
'the first row in the array is the channels names
AllChannelsData(i, 0) = channelList(i)
Set RecChannel = Rec.FindChannel(channelList(i), RecDevice.Name)
For j = 0 To total_time
AllChannelsData(i, j + 1) = RecChannelData.GetRecData(RecChannel, 1, 0)
Next
Next
Thanks!
please refer the code below.
Sub Array_test()
Dim GetRecData(9) As String
Dim AllChannelsData(9, 2) As String
For i = 0 To 9
GetRecData(i) = i
For j = 0 To 9
AllChannelsData(j, 0) = j
AllChannelsData(j, 1) = GetRecData(j)
Next j
Next i
End Sub
Change this:
For j = 0 To total_time
AllChannelsData(i, j + 1) = RecChannelData.GetRecData(RecChannel, 1, 0)
Next
to this
For j = 0 To total_time
AllChannelsData(i, j + 1) = RecChannelData.GetRecData(RecChannel, 1, j)
Next
maybe?
I'm assuming the third parameter of the .GetRecData(RecChannel, 1, 0) method is the index since 1D arrays like you're describing don't take 3 parameters. If that's not it, you may need to expand on what the GetRecData method is/does/returns/etc.
this "base" code works
Option Explicit
Sub main()
Dim arr1 As Variant
Dim arr2() As Variant
Dim total_time As Integer, i As Integer, j As Integer
total_time = 4
ReDim arr2(0 To 3, 0 To total_time)
For i = 0 To 3
arr2(i, 0) = i
For j = 1 To total_time
arr2(i, j) = GetRecData(j + 1)
Next j
Next i
End Sub
Function GetRecData(n As Integer) As Variant
ReDim arr(0 To n - 1) As Variant
Dim i As Integer
For i = 1 To n
arr(i - 1) = i
Next i
GetRecData = arr
End Function
just adapt it to your needs