I have tried without success to display a non-contiguous range of row cells into a 2-column listbox in Excel 2016. The lastest suggestion I'm using is to move range values into an array and use the array to write to the listbox.
I used the FindAll function to search through a large name range to extract rows that met the string criteria. I end up with a 28 row x 4 column non-contiguous range ( eg: A3:D3, A7:D7, A15:D15, A25:D25, ...) .
My issue is at the top of the 2nd loop cycle:
Dim result As Range, item As Range
Dim Arr() As String, sStr As String
sStr = "A3:D3","A7:D7","A15:D15","A25:D25"
Set result = Range(sStr)
i = 0
For Each item In result
ReDim Preserve Arr(i+1, 4)
Arr(i , 1) = item(1, 1).Value
Arr(i , 2) = item(1, 2).Value
Arr(i , 3) = item(1, 3).Value
Arr(i , 4) = item(1, 4).Value
i = i + 1
Next
The 1st loop interation works with correct values passed from item -> Arr, but at the 2nd loop all goes awry. Looking at the watch list the item.values are not correct and loop bombs at ReDim statement with a runtime error '9': Subscript out of range. It must be the range index and/or ReDim statement.
Does this work for you?
Dim result As Range, item As Range
Dim Arr() As String, sStr As String
sStr = "A3:D3,A7:D7,A15:D15,A25:D25"
Set result = Range(sStr)
ReDim Arr(result.Areas.Count, 4)
i = 0
For Each item In result.Areas
Arr(i, 1) = item(1, 1).Value
Arr(i, 2) = item(1, 2).Value
Arr(i, 3) = item(1, 3).Value
Arr(i, 4) = item(1, 4).Value
i = i + 1
Next
Related
I am trying to copy values from once column to another using vba. I am using the follwoing vba script:
Private Sub Import_Click()
Worksheets("test").Range("D10:D49") = Worksheets("test2").Range("G22:G61").Value
End Sub
But this just copies the values from one column to another. My question is this, consider the example below:
I want to copy the "Num" from table 1 to table 2 by matching it with the "items". Is there a way to do it using VBA? cuz, my actual list is really long.
If you are dealing with a large number of data and want to use VBA you can use dynamic arrays.
Try this example :
I have reproduced your example assuming first table is located on columns A & B, and 2nd one E & F (boths on first line):
Sub lookup_with_arrays()
Dim wb As Workbook
Dim ws As Worksheet
Dim arr1(), arr2() As Variant
Dim lastrow_arr1, lastrow_arr2, i, j As Long
Set wb = Workbooks("Your_File.xlsm")
Set ws = wb.Worksheets("Your_Sheet")
lastrow_arr1 = Range(ws.Cells(1, 1), ws.Cells(1, 1).End(xlDown)).Rows.Count
lastrow_arr2 = Range(ws.Cells(1, 5), ws.Cells(1, 5).End(xlDown)).Rows.Count
'Set dynamic dimensions
ReDim arr1(1 To lastrow_arr1, 1 To 2)
ReDim arr2(1 To lastrow_arr2, 1 To 2)
'Indicate which data to set up in the arrays
For i = LBound(arr1) To UBound(arr1)
arr1(i, 1) = ws.Cells(i, 1)
arr1(i, 2) = ws.Cells(i, 2)
Next i
For i = LBound(arr2) To UBound(arr2)
arr2(i, 1) = ws.Cells(i, 5)
arr2(i, 2) = ws.Cells(i, 6)
Next i
'Now we can match both Items colums and complete arr2 second column
For i = LBound(arr1) To UBound(arr1)
For j = LBound(arr2) To UBound(arr2)
If arr1(i, 1) = arr2(j, 1) Then
arr2(j, 2) = arr1(i, 2)
Exit For
End If
Next j
Next i
'Then you can report arr2 in your worksheet
For i = 2 To UBound(arr2)
ws.Cells(i, 6) = arr2(i, 2)
Next i
End Sub
Another option would be to use a Vlookup function :
Function VLOOKUP(TheValueYouNeed As Variant, RangeOfSearch As Range, No_index_col As Single, Optional CloseValue As Boolean)
On Error GoTo VLookUpError
VLOOKUP = Application.VLOOKUP(TheValueYouNeed, RangeOfSearch, No_index_col, CloseValue)
If IsError(VLOOKUP) Then VLOOKUP = 0
Exit Function
VLookUpError:
VLOOKUP = 0
End Function
I am not the creator of the function but I don't remember where I have found it (thanks anyway)
And then use it nearly as if you were in excel :
Sub lookup_using_function()
Dim lastrow_arr1, lastrow_arr2, i As Long
Dim looked_item As Variant
Dim search_table As Range
Dim col_num As Single
Dim bool As Boolean
Dim wb As Workbook
Dim ws As Worksheet
Set wb = Workbooks("Your_File.xlsm")
Set ws = wb.Worksheets("Your_Sheet")
lastrow_arr1 = Range(ws.Cells(1, 1), ws.Cells(1, 1).End(xlDown)).Rows.Count
lastrow_arr2 = Range(ws.Cells(1, 5), ws.Cells(1, 5).End(xlDown)).Rows.Count
Set search_table = ws.Range("A:B")
col_num = 2
bool = False
For i = 2 To lastrow_arr2
looked_item = ws.Cells(i, 5)
ws.Cells(i, 6) = VLOOKUP(looked_item, search_table, col_num, bool)
Next i
Then I usually insert a form, right click on it to assign a macro.
On click the macro assigned is executed.
Edit following your comment:
Cells() works with coordinates.
For example ws.Cells(5,4) stands for cell 5th row of 4th column in the worksheet called ws.
So If your table starts on line 6 and column 3:
'Indicate which data to set up in the arrays (i+5 instead of i)
For i = LBound(arr1) To UBound(arr1)
arr1(i, 1) = ws.Cells(i+5, 3)
arr1(i, 2) = ws.Cells(i+5, 4)
Next i
LBound and Ubound are useful in order to set for loop for an entire array.
To loop through rows:
For i=LBound(arr1) to UBound(arr1)
Next i
To loop through columns you provide the additional argument 2 (default is 1)
For i=LBound(arr1, 2) to UBound(arr1, 2)
Next i
If your table have various columns you may have to loop also through columns to specify which data you want:
For i=LBound(arr1) to UBound(arr1)
For j=LBound(arr1, 2) to UBound(arr1, 2)
arr1(i, j) = ws.Cells(i+5, j+2)
Next j
Next i
Edit: By print array I mean put the array onto a range in a sheet :)
I am using the following code on a table in excel with VBA. This combines rows with matching sales rep. Below is the source table. This is loaded into an array.
After running the below code the rows are combined and I null out the rows that were combined. My challenge is to print certain columns and only print the non null rows. To accomplish this I was trying to loop through the array and create another array with just the non null rows.
Sub mergeCategoryValues2()
Dim arr2 As Variant
Dim rowcount As Long
Dim i As Variant
Dim colcount As Long
arr2 = ActiveSheet.ListObjects("APPLE").Range
rowcount = UBound(arr2, 1)
colcount = UBound(arr2, 2)
For i = rowcount To 2 Step -1
If arr2(i, 3) = arr2(i - 1, 3) Then
arr2(i - 1, 6) = arr2(i - 1, 6) + arr2(i, 6)
For k = 1 To colcount
arr2(i, k) = Null 'this loop is probably not required i can probably just use the first column
Next k
End If
Next i
End Sub
Ultimately I wanted to print just the non null rows and just Columns 3,2,and 6. The best way I thought was to create an array with non null rows
Create an array for the results with the same number of rows as the data array. Scan down the data rows and at each change of value in column C increment a row counter for the results array . Dump the used part of the results using resize.
update - include headers
Sub mergeCategoryValues2()
Dim arr2 As Variant, arOut As Variant
Dim rowcount As Long, colcount As Long
Dim i As Long, k As Long, v
arr2 = ActiveSheet.ListObjects("APPLE").Range
rowcount = UBound(arr2, 1)
colcount = UBound(arr2, 2)
ReDim arOut(1 To rowcount, 1 To 3)
For i = 1 To rowcount
If arr2(i, 3) = v Then
arOut(k, 3) = arOut(k, 3) + arr2(i, 6)
Else
k = k + 1
v = arr2(i, 3) ' compare with following rows
arOut(k, 1) = arr2(i, 2)
arOut(k, 2) = arr2(i, 3)
arOut(k, 3) = arr2(i, 6)
End If
Next i
Sheet2.Range("A1").Resize(k, 3).Value2 = arOut
MsgBox "OK"
End Sub
I have an Excel formula that operates on a pre-existing range of data.
The Excel formula is: =STDEV.S(IF(FREQUENCY(range,range),range)) , where "range" is the aforementioned range of data.
My goal is to convert this formula into VBA code.
The following code is my attempt at trying to convert the formula into VBA, as well as my visualization of the process to try and understand why it is not putting out the same result:
Private Sub CommandButton1_Click()
Dim diffArray() As Variant
Dim i As Integer
Dim x As Integer
Dim array1() As Variant, size As Integer, j As Integer
Dim freqArray1() As Variant
Dim freqArray2() As Variant, size2 As Integer, j2 As Integer
'assigns the data values to array1
size = 0
j = 0
ReDim array1(size)
For i = 3 To 15
size = size + 1
ReDim Preserve array1(size)
array1(j) = Cells(i, 2)
j = j + 1
Next i
Cells(20, 2).Value = UBound(array1)
Cells(21, 2).Value = LBound(array1)
If UBound(array1) > 1 Then Cells(19, 2).Value = WorksheetFunction.StDev_S(array1)
'setting freqArray1 to frequency(array1, array1)
freqArray1 = WorksheetFunction.Frequency(array1, array1)
Cells(20, 3).Value = UBound(freqArray1)
Cells(21, 3).Value = LBound(freqArray1)
For i = LBound(freqArray1) To (UBound(freqArray1))
Cells(2 + LBound(freqArray1) + i, 3).Value = freqArray1(i, 1)
Next i
If UBound(freqArray1) > 1 Then Cells(19, 3).Value = WorksheetFunction.StDev_S(freqArray1)
'setting freqArray2 to if(frequency(array1, array1), array1)
size2 = 0
j2 = 0
ReDim freqArray2(size2)
For i = LBound(freqArray1) To (UBound(freqArray1))
If freqArray1(i, 1) Then
size2 = size2 + 1
ReDim Preserve freqArray2(size2)
freqArray2(j2) = freqArray1(i, 1)
j2 = j2 + 1
End If
Next i
Cells(20, 4).Value = UBound(freqArray2)
Cells(21, 4).Value = LBound(freqArray2)
For i = (LBound(freqArray2)) To UBound(freqArray2)
Cells(2 + LBound(freqArray2) + i, 4).Value = freqArray2(i)
Next i
'takes the standard deviation of if(frequency(array1, array1), array1)
If UBound(freqArray2) > 1 Then Cells(19, 4).Value = WorksheetFunction.StDev_S(freqArray2)
End Sub
The data values being operated on are in the orange cells column B(array1).
The array 'frequency(array1, array1)' is in the yellow cells column C.
The array 'if(frequency(array1, array1), array1)' is in the green cells column D.
The goal is for the values in the two blue cells(B18 and D19) to be the same.
I don't understand two things:
Why are the values in the blue cells(B18 and D19) not the same?
Why do the indices of the arrays change?
One starts at '0', the next starts at '1', and the last starts at '-1'?
use a dictionary to create a unique list and use that in the StDev_S
Private Sub CommandButton1_Click()
Dim dict As Object
Set dict = CreateObject("Scripting.Dictionary")
Dim rngArray As Variant
rngArray = ActiveSheet.Range("B3:B15")
Dim i As Long
For i = LBound(rngArray, 1) To UBound(rngArray, 1)
On Error Resume Next
dict.Add rngArray(i, 1), rngArray(i, 1)
On Error Resume Next
Next i
If dict.Count > 0 Then
Dim unqArr As Variant
ReDim unqArr(1 To dict.Count) As Variant
i = 1
Dim key As Variant
For Each key In dict.Keys
unqArr(i) = key
i = i + 1
Next key
ActiveSheet.Cells(19, 4).Value = Application.WorksheetFunction.StDev_S(unqArr)
End If
End Sub
The below VBA code sets a range of cells as commentArray, removes any blanks from the array and creates a new, blank free array, called commentResults. I then want to declare the array.
There is a possibility, depending on my source data, that the array could then still be empty so the below doesn't work to declare
thisws.Cells(i, 19).Resize(columnsize:=UBound(commentResults) - LBound(commentResults) + 1).Value = commentResults
So I thought I would add a check (the if statement after the debug.print), that only declared the array if array(0) wasn't empty but I continuously get an error 9 which I can't resolve.
Dim commentArray(4) As Variant
commentArray(0) = Cells(24, 4).Value
commentArray(1) = Cells(25, 3).Value
commentArray(2) = Cells(26, 3).Value
commentArray(3) = Cells(27, 3).Value
'a and b as array loops
Dim a As Long, b As Long
Dim commentResults() As Variant
'loops through the array to remove blanks - rewrites array without blanks into commentArray
For a = LBound(commentArray) To UBound(commentArray)
If commentArray(a) <> vbNullString Then
ReDim Preserve commentResults(b)
commentResults(b) = commentArray(a)
b = b + 1
End If
Next a
Debug.Print b
If IsError(Application.Match("*", (commentResults), 0)) Then
Else
thisws.Cells(i, 19).Resize(columnsize:=UBound(commentResults) - LBound(commentResults) + 1).Value = commentResults
b = 0
End If
Any thoughts on why this might not work?
I have also tried:
If commentResults(0) <> vbNullString Then
thisws.Cells(i, 27).Resize(columnsize:=UBound(commentResults) - LBound(commentResults) + 1).Value = commentResults
End If
Sub CommentArray()
Dim Comments As Range, c As Range
Set Comments = Union(Cells(24, 4), Range(Cells(25, 3), Cells(27, 3)))
Dim commentResults() As Variant
Dim i As Long
i = 0
For Each cell In Comments
If cell.Value <> "" Then
ReDim Preserve commentResults(i)
commentResults(i) = cell.Value
i = i + 1
End If
Next cell
Dim debugStr As String
For i = LBound(commentResults) To UBound(commentResults)
debugStr = debugStr & commentResults(i) & Chr(10)
Next i
MsgBox debugStr
End Sub
I have data that I need to split into individual points. My macro charts the data, as a scatter plot, with: Column A as the title of the chart, Column B as the X axis, and Columns C and D as the Y axis. What I need is for when the Product ID has more than 1 number listed to split the numbers out into their own rows and keep the columns B, C, and D the same for each row created form the original. So for row 167, I would want 3 rows (001,002,003) each with packaging, 200, and 100, in B, C, and D respectively. I am not sure where to begin. I tried to build a macro but, I immediately got tripped up when I tried to record a "Find" Formula to run on the data. Any help would be greatly appreciated.
Column A: 001, 002, 003 // Column B:packaging // Column C:200 // Column D:100
Sorry I couldn't post a screenshot of my data, the forum won't let me. If you have any questions please let me know, I will be sure to check in frequently.
Thanks in advance.
I worte this VERY quickly and without much care for efficiency, but this should do the trick:
Sub SplitUpVals()
Dim i As Long
Dim ValsToCopy As Range
Dim MaxRows As Long
Dim ValToSplit() As String
Dim CurrentVal As Variant
MaxRows = Range("A1").End(xlDown).Row
For i = 1 To 10000000
ValToSplit = Split(Cells(i, 1).Value, ",")
Set ValsToCopy = Range("B" & i & ":D" & i)
For Each CurrentVal In ValToSplit
CurrentVal = Trim(CurrentVal)
Cells(i, 1).Value = CurrentVal
Range("B" & i & ":D" & i).Value = ValsToCopy.Value
Cells(i + 1, 1).EntireRow.Insert
i = i + 1
MaxRows = MaxRows + 1
Next
Cells(i, 1).EntireRow.Delete
If i > MaxRows Then Exit For
Next i
End Sub
As a note, make sure there's no data in cells beneath your data as it might get deleted.
You will need to parse the data in column A. I would do this by splitting the string in to an array, and then iterate over the array items to add/insert additional rows where necessary.
Without seeing your worksheet, I would probably start with something like this, which will split your cell value from column A in to an array, and then you can iterate over the items in the array to manipulate the worksheet as needed.
Sub TestSplit()
Dim myString as String
Dim myArray() as String
Dim cell as Range
Dim i as Long
For each cell in Range("A2",Range("A2").End(xlDown))
myString = cell.Value
myArray = Split(myString, ",") '<-- converts the comma-delimited string in to an array
For i = lBound(myArray) to uBound(myArray)
If i >= 1 Then
'Add code to manipulate your worksheet, here
End If
Next
Next
End Sub
This is a better solution (now that I had more time :) ) - Hope this does the trick!
Sub SplitUpVals()
Dim AllVals As Variant
Dim ArrayIndex As Integer
Dim RowLooper As Integer
AllVals = Range("A1").CurrentRegion
Range("A1").CurrentRegion.Clear
RowLooper = 1
For ArrayIndex = 1 To UBound(AllVals, 1)
ValToSplit = Split(AllVals(ArrayIndex, 1), ",")
For Each CurrentVal In ValToSplit
CurrentVal = Trim(CurrentVal)
Cells(RowLooper, 1).Value = CurrentVal
Cells(RowLooper, 2).Value = AllVals(ArrayIndex, 2)
Cells(RowLooper, 3).Value = AllVals(ArrayIndex, 3)
Cells(RowLooper, 4).Value = AllVals(ArrayIndex, 4)
RowLooper = RowLooper + 1
Next
Next ArrayIndex
End Sub
Sub DivideData()
'This splits any codes combined into the same line, into their own separate lines with their own separate data
Dim a, b, txt As String, e, s, x As Long, n As Long, i As Long, ii As Long
With Range("a1").CurrentRegion
a = .Value
txt = Join$(Application.Transpose(.Columns(1).Value))
x = Len(txt) - Len(Replace(txt, ",", "")) + .Rows.Count
ReDim b(1 To x * 2, 1 To UBound(a, 2))
For i = 1 To UBound(a, 1)
For Each e In Split(a(i, 1), ",")
If e <> "" Then
For Each s In Split(e, "-")
n = n + 1
For ii = 1 To UBound(a, 2)
b(n, ii) = a(i, ii)
Next
b(n, 1) = s
Next
End If
Next
Next
With .Resize(n)
.Columns(1).NumberFormat = "#"
.Value = b
End With
End With
End Sub