I am trying to copy a range of cells from a range of rows from two workbooks. This information is used to do a comparison of the contents of both workbooks rows by ID.
The first solution I tried involved cell by cell "binary" comparison. This works for worksheets with few rows:
For i = 2 To LastSheetRow
Set FoundCell = Workbooks(WorkbookA).Sheets(SheetNameFromArray).Range("A:A").Find(What:=Workbooks(WorkbookB).Sheets(SheetNameFromArray).Cells(i, 1).Value)
If Not FoundCell Is Nothing Then
aCellValues(0) = 1
Workbooks(UserWorkbook).Sheets(SheetNameFromArray).Cells(i, LastSheetColumn + 1).Value = FoundCell.Row
For j = 2 To LastSheetColumn
Select Case Workbooks(WorkbookB).Sheets(SheetNameFromArray).Cells(i, j).Value
Case Is = Workbooks(WorkbookA).Sheets(SheetNameFromArray).Cells(FoundCell.Row, j).Value
aCellValues(j - 1) = 1
Case Else
aCellValues(j - 1) = 0
End Select
Next j
Else
End If
Next i
I would like to store the contents of one row of each of the two workbooks on one array to do the comparison, as I believe it's a faster solution.
After defining the range to do the comparison I encountered the following error when copying the cells into an array:
Subindex out of interval (Error 9)
This generates the error:
Dim aWorkbookBInfo() As Variant, aWorkbookAInfo() As Variant, rngWorkbookBToCompare As Range, rngWorkbookAToCompare As Range
Dim SumToCheck As Integer, FoundCell As Range, aCellValues() As Integer
ReDim aCellValues(LastSheetColumn - 1)
ReDim aWorkbookBInfo(LastSheetColumn - 1)
ReDim aWorkbookAInfo(LastSheetColumn - 1)
For i = 2 To LastSheetRow
Set FoundCell = Workbooks(WorkbookA).Sheets(SheetNameFromArray).Range("A:A").Find(What:=Workbooks(WorkbookB).Sheets(SheetNameFromArray).Cells(i, 1).Value)
If Not FoundCell Is Nothing Then
aCellValues(0) = 1
Workbooks(WorkbookB).Sheets(SheetNameFromArray).Cells(i, LastSheetColumn + 1).Value = FoundCell.Row
With Workbooks(WorkbookB).Sheets(SheetNameFromArray)
Set rngWorkbookBToCompare = Range(Cells(i, 2), Cells(i, LastSheetColumn))
End With
With Workbooks(WorkbookA).Sheets(SheetNameFromArray)
Set rngWorkbookAToCompare = Range(Cells(FoundCell.Row, 2), Cells(FoundCell.Row, LastSheetColumn))
End With
aWorkbookBInfo = rngWorkbookBToCompare
aWorkbookAInfo = rngWorkbookAToCompare
For j = 1 To LastSheetColumn - 1
If aWorkbookBInfo(j).Value = aWorkbookAInfo(j).Value Then
aCellValues(j) = 1
Else
aCellValues(j) = 0
End If
Next j
Else
End If
Next i
Complete Revision:
The range array assignment produces a two-dimensional array in these lines:
aWorkbookBInfo = rngWorkbookBToCompare
aWorkbookAInfo = rngWorkbookAToCompare
This happens regardless of how you defined and dimensioned them at the beginning of your code. Since they are a two-dimensional array, they must be addressed as aWorkbookBInfo(a, b) where a is a row and b is a column.
Unlike Ranges, where it is okay to reference the first cell in any range, you must fully address an array before attempting to reference the array item. So, while rngWorkbookBToCompare(j).Value works, aWorkbookBInfo(j).Value does not. Furthermore, Value is not necessarily a property of whatever object Excel puts in the array. If you want the first cell of column j, try adding the row and leaving off the reference to the Value property as in: aWorkbookBInfo(1, j).
Related
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'm trying to create an associative table on a sheet that is pulling in data from a different sheet. By associative I mean, if the data is changed in the source data sheet, it would be reflected on the new sheet. I also want to only have the new sheet's table to be contingent on having a certain unique value. In my case, I want to pull up information related to a part number. The original source data will have many rows that contain the same part number, but I only care to display one of them.
So far, this is what I have:
Function IsInArray(stringToBeFound As String, arr As Variant) As Boolean
Dim bDimen As Byte, i As Long
On Error Resume Next
If IsError(UBound(arr, 2)) Then bDimen = 1 Else bDimen = 2
On Error GoTo 0
Select Case bDimen
Case 1
On Error Resume Next
IsInArray = Application.Match(stringToBeFound, arr, 0)
On Error GoTo 0
Case 2
For i = 1 To UBound(arr, 2)
On Error Resume Next
IsInArray = Application.Match(stringToBeFound,
Application.index(arr, , i), 0)
On Error GoTo 0
If IsInArray = True Then Exit For
Next
End Select
End Function
Sub Part_Separator()
Dim Source As Worksheet
Set Source = Sheets("Part Tracking Scorecard")
Dim ref1(), ref2() As Variant
Dim row, index, lastrow, lastcolumn As Integer
row = 92
lastrow = 866
lastcolumn = 84
ref1 = Source.Range(Source.Cells(row, 1), Source.Cells(lastrow, lastcolumn))
ReDim ref2(UBound(ref1, 1), UBound(ref1, 2))
For index = 0 To (lastrow - row)
If IsInArray(ref1(index, 6).Value, ref2) Then
index = index + 1
Else
ref2(index) = ref1(index) 'copy the entire row from source to ref2
index = index + 1
End If
Next index
Dim NewFile As Worksheet
Set NewFile = Sheets("Unique Parts")
Dim ref2dimension_x, ref2dimension_y As Integer 'find dimensions of ref2 array
ref2dimension_x = UBound(ref2, 1) - LBound(ref2, 1) + 1
ref2dimension_y = UBound(ref2, 2) - LBound(ref2, 2) + 1
For index = 2 To ref2dimension_x 'go through entire new sheet and set values
For index2 = 1 To ref2dimension_y
NewFile.Cells(index, index2).Value = ref2(index - 1, index2)
Next index2
Next index
Erase ref1()
Erase ref2() 'free up the space occupied by these arrays
End Sub
My issue when I run this, I get an error at the first for loop where I'm trying to iterate through my ref1 array, which is the array with all my source data. The error says that my subscript is out of range. This loop is suppose to check if the specific value is in my ref2 array for uniqueness. If the specific value is found, go onto the next row, if not add the row of values associated to the value I'm checking to ref2.
Suppose I have a two column array in excel where the first column is text and the second column is numbers. I would like to have a command that would return an array sorted according to the values in the second column. I don't want to use the custom sort command because I would like to be able to update the numerical values in the second column and automatically have the sorted array updated.
The only other way of sorting automatically is by programming... MACROs.
You can either create a button and assign the macro to that button
OR
You put it in a selection change event which runs your macro every time a cell has changed.
up to you.
In the following code I did it for a button:
Sub btnSort()
Dim swapped As Boolean ' Boolean value to check if the values have been swapped
Dim boolEmpty As Boolean ' Boolean value to check if the cell value is empty
Dim tmp1, tmp2 As Variant ' Temporary variable,which holds temporary value
Dim numRows As Integer ' Number of NON-EMPTY rows
Dim tempArray1 As Variant ' Holds values in column 1 with certain values
Dim tempArray2 As Variant ' Holds values in column 2 with numerica values
boolEmpty = False 'Give initial value to variable; Assuming that the first checked cell is NOT EMPTY
'Count the number of cells with actual values in them
numRows = 0
ctr = 1
Do While (boolEmpty <> True)
'If the cell value contains something then increment variable numRows
If Sheet6.Cells(ctr, 1).Value > 0 Then
numRows = numRows + 1
boolEmpty = False
ctr = ctr + 1
Else
'if true then exit while loop
boolEmpty = True
End If
Loop
ReDim tempArray1(numRows) ' Re-dimensionalize the array with the appropriate size
ReDim tempArray2(numRows) ' Re-dimensionalize the array with the appropriate size
'Fill tempArray1 & 2 with values
For i = 0 To numRows - 1
tempArray1(i) = Sheet6.Cells(i + 1, 1).Value
tempArray2(i) = Sheet6.Cells(i + 1, 2).Value
Next i
'Set variables
swapped = True
ctr = 0
'If swapped remains TRUE then continue sorting the array
Do While (swapped)
swapped = False
ctr = ctr + 1
'BUBBLE SORT
'Check if next element in array is bigger than the first one.
'If TRUE then swap the elements
'If FALSE then continue until looking through teh array until done.
For i = 0 To numRows - ctr
If tempArray2(i) > tempArray2(i + 1) Then
tmp1 = tempArray1(i)
tmp2 = tempArray2(i)
tempArray1(i) = tempArray1(i + 1)
tempArray2(i) = tempArray2(i + 1)
tempArray1(i + 1) = tmp1
tempArray2(i + 1) = tmp2
swapped = True
End If
Next i
Loop
'Redisplay the sorted array in excel sheet
For i = 0 To UBound(tempArray2)
Sheet6.Cells(i + 1, 1).Value = tempArray1(i)
Sheet6.Cells(i + 1, 2).Value = tempArray2(i)
Next i
End Sub
The reason I did it for a button is because if you do it the selection change event way your excel is constantly going to refresh every time you change a cell. BUT, there is a work around for this.
In the example above I used bubble sort, you can find many examples on how to understand it online somewhere.
if you want my code to work you will have to change my sheet6.cells(....
to
your sheet number, depending where your list is found in your workbook.
In the "Count the number of cells with actual values..."
You will have to change ...Cells(ctr,1) to the row and column index where your list is found.
Hope I didn't confuse you.
Here is the other way I was talking about earlier:
'If value has changed in column 2 then run macro
Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Column > 1 And Target.Column < 3 Then
MsgBox Target.Column
End If
End Sub
This code needs to be in the same sheet. It checks to see if the value that you changed is in fact within column 2 ( Target.Column > 1 And Target.Column < 3 ) You can go a step further and add Target.row < 10 (which means, the cell that was modified is column 2 and less than row 10)
where you see msgbox is where you will copy and paste the code "bubble sort and etc.." in.
Hope this helps.
I am trying to delete blank entries from an array that was loaded from a field called TY[L3 Name] (1 column, X rows long) from a data table in excel. The below code is intended to remove all blank values from the array (once it has been loaded with the range), and return a new array with rows that only have data in them. I will want to pass this array onto a collection later to remove duplicates, but I am trying to figure out why I can't get ride of the blanks first (now I am at a point where I just want to understand how to do this regardless if i pass this onto something else or not).
The code errors out at the ReDim Preserve line. I first sized the NewArr to the MyArr table, but had blank rows returned at the end. I then tried to resize it so I only had rows with data in them, but I cannot seem to get the NewArr() array to do this without an error.
I am using the immediate window to verify that there are no blank entries (currently 8 rows at the end of the TY[L3 Name] range).
Sub BuildArray()
' Load array
Dim MyArr()
Dim j As Long
' Size array
MyArr() = Range("TY[L3 Number]")
ReDim NewArr(LBound(MyArr) To UBound(MyArr), 1)
' For Loop to search for Blanks and remove from Array
' The Lbound and UBound parameters will be defined by the size of the TY[L3 Number] field in the TY Table
For i = LBound(MyArr) To UBound(MyArr)
If MyArr(i, 1) <> "" Then
j = j + 1
NewArr(j, 1) = MyArr(i, 1)
End If
Next i
ReDim Preserve NewArr(1 To j, 1) 'Error out here; "Subscript out of range." Can't seem to get this Array to new size without blank entries.
' Debug Window to show results of revised array.
Dim c As Long
For c = LBound(NewArr) To UBound(NewArr)
Debug.Print NewArr(c, 1)
Next
Debug.Print "End of List"
End Sub
Working through arrays can be tricky in VBA, but I think the example below will show you how a different strategy for populating the "No Blanks" Array might be work:
Suppose we start off with a single Worksheet, with the CoolRange named as shown:
Generating an array without blanks could be done like this:
Option Explicit
Sub BuildArrayWithoutBlanks()
Dim AryFromRange() As Variant, AryNoBlanks() As Variant
Dim Counter As Long, NoBlankSize As Long
'set references and initialize up-front
ReDim AryNoBlanks(0 To 0)
NoBlankSize = 0
'load the range into array
AryFromRange = ThisWorkbook.Names("CoolRange").RefersToRange
'loop through the array from the range, adding
'to the no-blank array as we go
For Counter = LBound(AryFromRange) To UBound(AryFromRange)
If AryFromRange(Counter, 1) <> "" Then
NoBlankSize = NoBlankSize + 1
AryNoBlanks(UBound(AryNoBlanks)) = AryFromRange(Counter, 1)
ReDim Preserve AryNoBlanks(0 To UBound(AryNoBlanks) + 1)
End If
Next Counter
'remove that pesky empty array field at the end
If UBound(AryNoBlanks) > 0 Then
ReDim Preserve AryNoBlanks(0 To UBound(AryNoBlanks) - 1)
End If
'debug for reference
For Counter = LBound(AryNoBlanks) To UBound(AryNoBlanks)
Debug.Print (AryNoBlanks(Counter))
Next Counter
Debug.Print "End of List"
End Sub
So, to summarize, we:
Create a 1-D array for our eventual array with blanks removed
Iterate through our original array (with blanks)
Unless the array field is blank, we increase our non-blank counter, then add the value to the non-blank array, then expand the non-blank array
Blow away the last pesky empty field in our non-blank array
From your problem description, it sounds like you'll eventually be stripping away duplicates with a Collection -- love it. Out of curiosity, what will you use the non-blank-but-with-duplicates array for?
I have worksheet data to remove the lines with "Templates" in them and copy to a second worksheet. Same idea as removing blank lines. I copied the raw data to INArr. I know the width is 16 (Columns) but the length (Rows) is variable. REDIM PRESERVE only works on the last dimension so I transposed the array so it is now 16 rows and unlimited columns while removing the unwanted data. Transpose the array back and copy to the final work sheet.
Hope that makes sense.
'Copy data from Worksheet3 to INArr, Remove "TEMPLATES" and copy to Worksheet2
LR = Sheet3.Cells(Rows.Count, "A").End(xlUp).Row
INArr = Sheet3.Range("B6:Q" & LR).Value2
ReDim TempArr(1 To 16, 1 To 1)
x = 0
For i = 1 To UBound(INArr)
If INArr(i, 14) <> "TEMPLATES" Then
x = x + 1
ReDim Preserve TempArr(1 To 16, 1 To x)
For j = 1 To 16
TempArr(j, x) = INArr(i, j)
Next
End If
Next
ReDim OutArr(1 To x, 1 To 16)
For i = 1 To x
For j = 1 To 16
OutArr(i, j) = TempArr(j, i)
Next
Next
Sheet2.Range("A3:P" & x + 2).Value2 = OutArr
I have been given the job of fixing a holiday spreadsheet at work, the problem with the document is that there are direct references, indirect references to other worksheets and some parts non referenced, so if you want to put people in a different order it completely messes the whole thing up. So, what I have been trying to do is to populate an array with the peoples names, sort the array, then cross reference that with the original and find a new order so that this new order can be implemented throughout the worksheets without messing things up.
The problem is that I can't seem to get the arrays to populate, I have looked at the other answers on here, but I'm sure I'm using redim properly and that tends to be the problem.
So Previous is the original listing, Current is the sorted list and Position is the number that relates the previous to the current.
Sub Sorting()
Dim Previous() As Variant
Dim Current() As Variant
Dim maxrow As Long
Dim i As Long
Dim j As Long
Dim k As Long
Dim Position() As Long
Dim rng As Range
Dim strTemp As String
k = 0
i = 3
maxrow = 3
Do While Worksheets(1).Cells(i, 1).Value <> "STAT.HOL'S (ST)"
maxrow = maxrow + 1
i = i + 1
Loop
maxrow = maxrow - 1
ReDim Previous(0 To maxrow)
ReDim Position(0 To maxrow)
ReDim Current(0 To maxrow)
Previous = Range("a4", Range("a" & maxrow))
Current = Previous
For i = 0 To maxrow
For j = 0 To maxrow
If Current(i) > Current(j) Then
strTemp = Current(i)
Current(i) = Current(j)
Current(j) = strTemp
End If
Next j
Next i
For i = 0 To maxrow
For j = 0 To maxrow
If Previous(i) = Current(j).Value Then
Position(k) = j
k = k + 1
End If
Next j
Next i
End Sub
Thanks for your help.
Amy
You do populate the arrays, but you are adressing them the wrong way.
When you assign a range to an array, the array is automatically redimensioned to a two-dimensional array, one for the rows and one for the columns.
Since your range is just one columm, the second dimension is always 1. So after you run the line Previous = Range("a4", Range("a" & maxrow)) you have an array that is dimensioned as:
Previous(1 to 10, 1 To 1)
Also, your For loops could be changed to something like this:
For i = LBound(Current, 1) To UBound(Current, 1)
Next i
Excel ranges are always treated as having 2 dimensions even when they are a single column.
Also you don't need to redim your variant arrays - just assign the range to a plain variant variable and it will create a variant containing a 2-dimensional array:
Dim Previous as variant
Previous = Range("a4:a" & maxrow)