I want to copy a set of values from an array than meet the condition (values < 70 for example) to the next column
'Qo reported (bd) - array
For i = 0 To cap
array_Qorep(i, 0) = Range("A" & i + 1)
Cells(i + 1, 3) = array_Qorep(i, 0) 'copy array in the next column
If Cells(i + 1, 1).Value = Empty Then Exit For 'more values below, stop in blank
Next
the problem is that i don't know how to apply the condition i want in the array and then copying to the next column, is there a way to delete the values that doesn't meet the condition from the array and then copy them?
here is the solution for some reason it didnt work before but now it does :)
, and thanks Absinthe
'Qo reported (bd)
For i = 0 To cap
array_Qorep(i, 0) = Range("A" & i + 1)
If Cells(i + 1, 1).Value = Empty Then Exit For
If array_Qorep(i, 0) > Cells(3, 4) Then
Cells(i + 1, 3) = array_Qorep(i, 0)
End If
Next
Does this do it? Build your array first then:
arrPos = 1
For x = 0 to myArray.length
if myArray(x,0) < 70 then
cells(arrPos, 1) = myArray(x, 0)
arrPos = arrPos + 1
End If
next x
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 am trying to make a loop to go through an array(47193, 4) and an array 2 named attack(41892,1). The idea here is that the attack array has the values in order from the sheet i want to later on add the values to the next column, this is why i add the values to a third array. So the loop is going to go one by one the value from attack array while looping through arr array to find the common data. i tried copying the values directly to the sheet but excel freezes a lot. Now with this way, excel still freezes at this point. Is there anything wrong with it?
Dim arr3() As Variant
Dim dee As Long
ReDim arr3(UBound(attacks, 1), 1)
For k = 0 To UBound(attacks, 1)
j = 0
For j = 0 To UBound(arr, 1)
If attacks(k, 0) = arr(j, 0) And attacks(k, 1) = arr(j, 2) Then
arr3(dee, 0) = attacks(k, 0)
arr3(dee, 1) = attacks(k, 1)
de = dee + 1
End If
Next j
Next k
Here's some code showing how to use a Dictionary:
Sub Tester()
Const SZ As Long = 10000 'size of test arrays
Dim arr1(1 To SZ, 1 To 2)
Dim arr2(1 To SZ, 1 To 2)
Dim arr3(1 To SZ, 1 To 2) '<<matches go here
Dim n As Long, m As Long, i As Long, t, dict, k
t = Timer
'fill test arrays with random data
For n = 1 To SZ
arr1(n, 1) = CLng(Rnd * 200)
arr1(n, 2) = CLng(Rnd * 200)
arr2(n, 1) = CLng(Rnd * 200)
arr2(n, 2) = CLng(Rnd * 200)
Next n
Debug.Print "Filled test arrays", Timer - t
t = Timer
'test the nested loop approach
For n = 1 To SZ
For m = 1 To SZ
If arr1(n, 1) = arr2(m, 1) And arr1(n, 2) = arr2(m, 2) Then
i = i + 1
arr3(i, 1) = arr1(n, 1)
arr3(i, 2) = arr1(n, 2)
End If
Next m
Next n
Debug.Print "Finished nested loop", Timer - t, i & " matches"
t = Timer
'create a lookup using a dictionary
Set dict = CreateObject("scripting.dictionary")
For n = 1 To SZ
k = arr1(n, 1) & "|" & arr1(n, 2)
dict(k) = dict(k) + 1
Next n
Debug.Print "Filled dictionary", Timer - t
t = Timer
i = 0
Erase arr3
'Perform the match against arr2 using the dictionary
For m = 1 To SZ
k = arr2(m, 1) & "|" & arr2(m, 2)
If dict.exists(k) Then
i = i + 1
arr3(i, 1) = arr2(m, 1)
arr3(i, 2) = arr2(m, 2)
End If
Next m
Debug.Print "Finished dictionary loop", Timer - t, i & " matches"
End Sub
Output:
Filled test arrays 0
Finished nested loop 9.101563 2452 matches
Filled dictionary 0.03125
Finished dictionary loop 0.0078125 2177 matches
Note the # of matches is slightly different - the nested loop catches duplicate matches but the Dictionary only counts unique matches. You might need to make adjustments depending on your use case.
this is part of my code that i am working with and I have one problem. I have array with values (masyvas) and i started new loop to find other values by using masyvas(i,1) values and after that i need that new values would be printed in masyvas(i,2) and i need to group them. It need to look like this:
991988 Gaz.duon.sk"Giros"gaiv.g.1,5L 5_PETØFLAT1,5
PALINK
117388 Silp.gaz.nat.min.v"Tiche'1,5L 5_PETØFLAT1,5
PALINK
RIMI LIETUVA
ŠIAULIŲ TARA
111388 Gaz.nat.min.v"Tiche" 1,5L pet 5_PETØFLAT1,5
PALINK
AIBĖS LOGISTIKA
AIBĖS LOGISTIKA
RIMI LIETUVA
ŠIAULIŲ TARA
How it looks now from marked 1 it goes wrong
Data sheet where i get array values
Here is part of my code where i have this problem now it prints new values next to masyvas(i,2) but not below as I need.
lastrow2 = Sheets("lapas").Cells(Rows.Count, 1).End(xlUp).Row
rub = lastrow2
cub = 3
ReDim masyvas(1 To rub, 1 To cub)
For i = 1 To rub
For j = 1 To cub
masyvas(i, j) = Sheets("lapas").Cells(i, j).Value 'array gets values from filtered data in AKCIJOS sheet
Next
Next
Sheets("lapas").Range("A1:C100").Clear
For i = 1 To rub Step 1
Set rng2 = grafikas.Cells(6 + h, 2)
prekeskodas = masyvas(i, 1)
For m = 2 To lastrow
If akcijos.Cells(m, 8) >= laikas And akcijos.Cells(m, 8) <= laikas2 Then
If prekeskodas = akcijos.Cells(m, 4) Then
grafikas.Cells(7 + r, 2).EntireRow.Select
Selection.Insert Shift:=xlDown
grafikas.Cells(7 + r, 3) = akcijos.Cells(m, 3)
r = r + 1
h = r
End If
End If
Next m
For j = 1 To cub Step 1
rng2.Offset(i - 1, j - 1).Value = masyvas(i, j)
Next
Next
You didn't provide any screenshot of your data, so it's hard to say what exactly is your problem and desired output, but try the code below. I marked changed lines.
For i = 1 To rub
prekeskodas = masyvas(i, 1)
For m = 2 To lastrow
If akcijos.Cells(m, 8) >= laikas And akcijos.Cells(m, 8) <= laikas2 Then
If prekeskodas = akcijos.Cells(m, 4) Then
'masyvas(i, 2) = masyvas(i, 2) & akcijos.Cells(m, 3)
masyvas(i, m) = masyvas(i, m) & akcijos.Cells(m, 3) '<------
End If
End If
Next
For j = 1 To cub
rng2.Offset(j - 1, i - 1).Value = masyvas(i, j) '<-----
Next
Next
i=19
With ListBox1
'clearing previous values from sheet
range(Cells(i + 2, 1).Address & ":" & Cells(endRwow, 7).Address).ClearContents
ListBoxArrSelected = vbNullString
For y = 0 To .ListCount - 1
If .Selected(y) Then
' concatenate all selected strings
ListBoxArrSelected = ListBoxArrSelected & "~" & ListBox1.List(y)
End If
Next y
' fill array with concatenated all selected strings spliting to rows
ListBoxArrSplitToRows = Split(ListBoxArrSelected, "~")
For UR = 1 To UBound(ListBoxArrSplitToRows, 1) + 1
' fill array with concatenated all selected strings spliting to colomuns
ListBoxArrSplitToCell = Split(ListBoxArrSplitToRows(UR - 1), "·")
For URc = 1 To UBound(ListBoxArrSplitToCell, 1) + 1
'paste to sheet
Cells(i + UR, 1).value = timeStr
Cells(i + UR, URc + 1).value = ListBoxArrSplitToCell(URc - 1)
Next URc
Next UR
End With
Then in listbox selected > 100 field excel responds very slow to copy them to worksheet
How to speed up this code?
You can reduce the number of cell writes using something like this:
i = 19
With ListBox1
Range(Cells(i + 2, 1), Cells(endRwow, 7)).ClearContents
ListBoxArrSelected = vbNullString
For y = 0 To .ListCount - 1
If .Selected(y) Then
ListBoxArrSelected = ListBoxArrSelected & "~" & ListBox1.List(y)
End If
Next y
ListBoxArrSplitToRows = Split(ListBoxArrSelected, "~")
Cells(i + 1, 1).Resize(UBound(ListBoxArrSplitToRows, 1) + 1).Value = timeStr
For UR = 1 To UBound(ListBoxArrSplitToRows, 1) + 1
ListBoxArrSplitToCell = Split(ListBoxArrSplitToRows(UR - 1), "·")
Cells(i + UR, 2).Resize(, UBound(ListBoxArrSplitToCell, 1) + 1).Value = ListBoxArrSplitToCell
Next UR
End With
If you have the same number of delimited items in each row of the listbox, you could create an array of arrays and then output that to the sheet in one write operation. Code would be something like this:
Dim ListBoxArrSplitToRows()
Dim counter As Long
Dim columnCount As Long
i = 19
Range(Cells(i + 2, 1), Cells(endRwow, 7)).ClearContents
With ListBox1
ReDim ListBoxArrSplitToRows(.ListCount - 1)
For y = 1 To .ListCount
If .Selected(y - 1) Then
' load subarray into array
ListBoxArrSplitToRows(counter) = Split(.List(y - 1), "·")
counter = counter + 1
End If
Next y
End With
' resize array to used extent
ReDim Preserve ListBoxArrSplitToRows(counter - 1)
' get column count using first subarray
columnCount = UBound(ListBoxArrSplitToRows(0)) + 1
Cells(i + 1, "B").Resize(counter, columnCount).Value = Application.Index(ListBoxArrSplitToRows, 0, 0)
or just Cells(i + 1, "B").Resize(counter, columnCount).Value = ListBoxArrSplitToRows
I am a newbie to VBA and have been developing a macro that involves arrays.
In the array part, I need to copy some ranges from two excel workbooks into two separate arrays(timearray and guzikarray). Then I will try to match the two arrays and copied the results into a third array(masterarray). Lastly I will write the third array's contents back into the worksheet.
But I found that my first two arrays' contents are automatically erased when I started to do the matching. So nothing was written back to my worksheet. Anyone can tell me why?
'copy ranges to two arrays: timearray and guzikarray
masterrows = mastersheet.UsedRange.Rows.count
guzikrows = guziksheet.UsedRange.Rows.count
ReDim timearray(1 To masterrows, 1 To 2)
For i = 1 To i = masterrows
timearray(i, 1) = Cells(i, 6).Value
timearray(i, 2) = Cells(i, 10).Value
Next
ReDim guzikarray(1 To guzikrows, 1 To 6)
For i = 1 To i = guzikrows
guzikarray(i, 1) = guziksheet.Cells(i, 11).Value
guzikarray(i, 2) = guziksheet.Cells(i, 17).Value
guzikarray(i, 3) = guziksheet.Cells(i, 14).Value
guzikarray(i, 4) = guziksheet.Cells(i, 16).Value
guzikarray(i, 5) = guziksheet.Cells(i, 18).Value
guzikarray(i, 6) = guziksheet.Cells(i, 26).Value
Next
'match timearray and guzikarray, and then copied the results to masterarray
ReDim Preserve masterarray(1 To masterrows, 1 To 4)
For i = 2 To i = masterrows
min = 100000
For j = 2 To j = guzikrows
If timearray(i, 1) = guzikarray(j, 1) Then
If timearray(i, 2) = guzikarray(j, 2) Then
If guzikarray(j, 6) <> 0 Then
masterarray(i, 1) = guzikarray(j, 4)
masterarray(i, 3) = guzikarray(j, 3)
If guzikarray(j, 5) < min Then
min = guzikarray(j, 5)
masterarray(i, 2) = min
End If
If timearray(i, 1) <> timearray(i + 1, 1) Then
If timearray(i, 1) <> timearray(i - 1, 1) Then
If guzikarray(j, 2) <> guzikarray(j - 1, 2) Then masterarray(i, 4) = guzikarray(j - 1, 5)
End If
End If
End If
End If
End If
Next
Next
'write the results back to master array
Range(Cells(2, 17), Cells(masterrows, 20)).Value = masterarray
Your loops aren't working as the syntax is incorrect
For i = 1 To i = masterrows
exits immediately without populating the array. You should be using
For i = 1 To masterrows
For i = 1 To guzikrows
etc