I have found a couple of other questions dealing with variants but none of them seem to address my issue.
I have very simple for loops doing comparisons. The purpose is to color the Excel cell red if there isn't a match. The results are 99% accurate, but I have noticed a couple of seemingly random errors. For example, a cell containing the number 104875 is not colored red, which indicates that there should be a matching cell in the comparison column. But there isn't. It seems like they should all be wrong or all be correct. Some of the other threads about variants have mentioned that the comparisons have to be of the same type or you will get weird errors. In my case, they are of the same type (both integers), so this isn't the problem.
I am brand new to VBA and still trying to understand how it works.
This is the relevant part of the code:
Private Sub CommandButton1_Click()
Dim i As Long, j As Long
Dim flag As Boolean
Dim array1() As Variant, array2() As Variant
Dim column1 As Double
Dim column2 As Double
column1 = convertColumn(TextBox1.Text)
column2 = convertColumn(TextBox2.Text)
Set wb1 = Workbooks("Advocate July 2017 Data.xlsm").Sheets(1)
Set wb2 = Workbooks("BI Report 8-18-17.xlsm").Sheets(1)
array1 = Intersect(wb1.Columns(column1), wb1.UsedRange)
array2 = Intersect(wb2.Columns(column2), wb2.UsedRange)
For i = 2 To UBound(array1)
flag = False
For j = 2 To UBound(array2)
If IsNumeric(array1(i, 1)) And IsNumeric(array2(j, 1)) Then If CDbl(array1(i, 1)) = CDbl(array2(j, 1)) Then flag = True
Next j
If Not flag Then wb1.Cells(i, column1).Interior.Color = vbRed
Next i
End Sub
EDIT: Turns out that my code works fine. The problem was simply that some of the cells on one of the sheets were hidden and I didn't realize it. ~facepalm~ that's what I get for being inexperienced in excell
Try to simplify your code, to something easily reproductible. E.g., lets say that you want to compare the first 50 cells in columns A and B in the activesheet. Put some values and it will look like this:
Option Explicit
Public Sub TestMe()
Dim array1 As Variant
Dim array2 As Variant
Dim i As Long
Dim j As Long
Dim flag As Boolean
With ActiveSheet
array1 = .Range("A1:A50")
array2 = .Range("B1:B50")
.Range("A1:A10").Interior.Color = vbWhite
For i = LBound(array1) To UBound(array1)
flag = False
For j = LBound(array2) To UBound(array2)
If array1(i, 1) = array2(j, 1) Then flag = True
Next j
If Not flag Then .Cells(i, 1).Interior.Color = vbRed
Next i
End With
End Sub
Then try to adapt the solution to yours. It should work.
Related
I have a spreadsheet that contains over 100k rows in a single column (I know crazy) and I need to find an efficient way to highlight partial duplicates and remove them. All the records are all in the same format, but may have an additional letter attached at the end. I would like to keep the first instance of the partial duplicate, and remove all instances after.
So from this:
1234 W
1234 T
9456 S
1234 T
To This:
1234 W
9456 S
I was going to use the formula below to conditionally highlight the partial dupes, but i receive an error "You may not use reference operators (such as unions....) or array constants for Conditional Formatting criteria" and use VBA to remove those highlighted cells.
=if(A1<>"",Countif(A$1:A,left(A1,4)& "*") > 1)
Any thoughts? I know conditional formatting is memory intensive, so if there's any way to perform this using VBA I'm open to suggestion.
Here is one way to remove the duplicates quickly:
Text to Columns, using space delimiter.
Remove Duplicates referring to duplicates in the first column only.
Merge the content of each row with =Concatenate(A1, B1).
If the "unique identifier" of each value is just its first 4 characters, then maybe the code below will be okay for you.
I recommend making a copy of your file before running any code, as code tries to overwrite the contents of column A. (The procedure to run is PreprocessAndRemoveDuplicates.)
You may need to change the name of the sheet (in the code). I assumed "Sheet1".
Code assumes data is only in column A.
Option Explicit
Private Sub PreprocessAndRemoveDuplicates()
Dim targetSheet As Worksheet
Set targetSheet = ThisWorkbook.Worksheets("Sheet1") ' Change to whatever yours is called. You could use code name instead too.
Dim lastCell As Range
Set lastCell = targetSheet.Cells(targetSheet.Rows.Count, "A").End(xlUp)
Debug.Assert lastCell.Row > 1
Dim inputArray() As Variant
inputArray = targetSheet.Range("A1", lastCell) ' Assumes data starts from A1.
Dim uniqueValues As Scripting.Dictionary
Set uniqueValues = New Scripting.Dictionary
Dim rowIndex As Long
For rowIndex = LBound(inputArray, 1) To UBound(inputArray, 1)
Dim currentKey As String
currentKey = GetKeyFromValue(CStr(inputArray(rowIndex, 1)))
If Not uniqueValues.Exists(currentKey) Then ' Only first instance added.
uniqueValues.Add currentKey, inputArray(rowIndex, 1)
End If
Next rowIndex
WriteDictionaryItemsToSheet uniqueValues, targetSheet.Cells(1, lastCell.Column)
End Sub
Private Function GetKeyFromValue(ByVal someText As String, Optional charactersToExtract As Long = 4) As String
' If below logic is not correct/appropriate for your scenario, replace with whatever it should be.
' Presently this just gets the first N characters of the string, where N is 4 by default.
GetKeyFromValue = Left$(someText, charactersToExtract)
End Function
Private Sub WriteDictionaryItemsToSheet(ByVal someDictionary As Scripting.Dictionary, ByVal firstCell As Range)
Dim initialArray() As Variant
initialArray = someDictionary.Items()
Dim arrayToWriteToSheet() As Variant
arrayToWriteToSheet = StandardiseArray(initialArray)
With firstCell
.EntireColumn.ClearContents
.Resize(UBound(arrayToWriteToSheet, 1), UBound(arrayToWriteToSheet, 2)).Value = arrayToWriteToSheet
End With
End Sub
Private Function StandardiseArray(ByRef someArray() As Variant) As Variant()
' Application.Transpose might be limited to ~65k
Dim baseDifference As Long
baseDifference = 1 - LBound(someArray)
Dim rowCount As Long ' 1 based
rowCount = UBound(someArray) - LBound(someArray) + 1
Dim outputArray() As Variant
ReDim outputArray(1 To rowCount, 1 To 1)
Dim readIndex As Long
Dim writeIndex As Long
For readIndex = LBound(someArray) To UBound(someArray)
writeIndex = writeIndex + 1
outputArray(writeIndex, 1) = someArray(readIndex)
Next readIndex
StandardiseArray = outputArray
End Function
Processed 1 million values (A1:A1000000) in under 3 seconds on my machine, but performance on your machine may differ.
I have a range consisting of two columns that the user would define thru Application.Inputbox method. I would store that as rng in the VBA to be copied then pasted later to some cells in Excel sheet. Before pasting, I would like to swap these two columns in rng. Is there a way to do that without a loop and without having to swap the actual original columns in the excel sheet?
So what I mean is something like this:
rng_swapped.Columns(1).Value = rng.Columns(2).Value
rng_swapped.Columns(2).Value = rng.Columns(1).Value
rng = rng_swapped
Use a variant array as an intermediate temporary storage so you can overwrite the original.
dim arr as variant
arr = rng_swapped.Columns(1).value
rng_swapped.Columns(1) = rng_swapped.Columns(2).Value
rng_swapped.Columns(2) = arr
from your narrative my understanding is that the range to paste to is different from the range to copy from.
so just go like this
Dim rng As Range
Set rng = Application.InputBox("Please select a range:", "Range Selection", , , , , , 8)
Dim rngToPaste As Range
Set rngToPaste = rng.Offset(, 20) ' just a guess...
rngToPaste.Columns(1).Value = rng.Columns(2).Value
rngToPaste.Columns(2).Value = rng.Columns(1).Value
How to use Jeeped's code
While playing around with the code... my curiosity fires away:
Why not:?
arr1 = oRng.Columns(1)
arr2 = oRng.Columns(2)
oRng.Columns(1) = arr2
oRng.Columns(2) = arr1
It turns out something (probably) the extra line makes the code slower (by about 10%).
I have a similar scenario and I know the range address. How should I use the code?
Sub SwapColumnsRange()
'Description
'In a specified range, swaps the first two columns i.e. the values of
'column(1) become the values of column(2) and the values of column(2) become
'the values of column(1).
'Arguments as constants
'cStrRange
'A string containing the Address of the range to be processed.
Const cStrRange As String = "A1:B50000" 'Your range address here.
Dim arr As Variant
Dim oRng As Range
Set oRng = Range(cStrRange)
If oRng.Areas.Count > 1 Then Exit Sub
If oRng.Columns.Count < 2 Then Exit Sub
'Slightly modified Jeeped's code
arr = oRng.Columns(1) '.Value
oRng.Columns(1) = oRng.Columns(2).Value
oRng.Columns(2) = arr
End Sub
I forgot to mention that I have more than two columns to be swapped!?
Sub ShiftColumnsRangeLeft()
'Description
'In a specified range with columns from 1 to 'n', shifts columns to the left
'i.e. the values of column(1) become the values of column(n), the values of
'column(2) become the values of column(1)... ...the values of column(n), the
'last column, become the values of column(n-1).
'Arguments as constants
'cStrRange
'A string containing the Address of the range to be processed.
Const cStrRange As String = "A1:I50000" 'Your range address here.
Dim arr As Variant
Dim oRng As Range
Dim i As Integer
Set oRng = Range(cStrRange)
If oRng.Areas.Count > 1 Then Exit Sub
If oRng.Columns.Count < 2 Then Exit Sub
For i = 1 To oRng.Columns.Count - 1 'ShiftColumnsRangeRight Difference
'Slightly modified Jeeped's code
arr = oRng.Columns(i) '.Value
oRng.Columns(i) = oRng.Columns(i + 1).Value
oRng.Columns(i + 1) = arr
Next
End Sub
You're a little off topic here, aren't you?
But not to this side, to the other side, please!?
Sub ShiftColumnsRangeRight()
'Description
'In a specified range with columns from 1 to 'n', shifts columns to the right
'i.e. the values of column(1) become the values of column(2), the values of
'column(2) become the values of column(3)... ...the values of column(n), the
'last column, become the values of column(1).
'Arguments as constants
'cStrRange
'A string containing the Address of the range to be processed.
Const cStrRange As String = "A1:I50000" 'Your range address here.
Dim arr As Variant
Dim oRng As Range
Dim i As Integer
Set oRng = Range(cStrRange)
If oRng.Areas.Count > 1 Then Exit Sub
If oRng.Columns.Count < 2 Then Exit Sub
For i = oRng.Columns.Count - 1 To 1 Step -1 'ShiftColumnsRangeLeft Difference
'Slightly modified Jeeped's code
arr = oRng.Columns(i) '.Value
oRng.Columns(i) = oRng.Columns(i + 1).Value
oRng.Columns(i + 1) = arr
Next
End Sub
I've changed my mind, I want to select a range and then run the macro to shift the columns!?
Sub ShiftColumnsSelectionRight()
'Description
'In a selection with columns from 1 to 'n', shifts columns to the right
'i.e. the values of column(1) become the values of column(2), the values of
'column(2) become the values of column(3)... ...the values of column(n), the
'last column, become the values of column(1).
Dim arr As Variant
Dim oRng As Range
Dim i As Integer
Set oRng = Selection
If oRng.Areas.Count > 1 Then Exit Sub
If oRng.Columns.Count < 2 Then Exit Sub
For i = oRng.Columns.Count - 1 To 1 Step -1 'ShiftColumnsRangeLeft Difference
'Slightly modified Jeeped's code
arr = oRng.Columns(i) '.Value
oRng.Columns(i) = oRng.Columns(i + 1).Value
oRng.Columns(i + 1) = arr
Next
End Sub
I've had it! Do the other two versions (Swap & ShiftLeft) yourself!
Remarks
These examples demonstrate how by making some simple modifications, the code can be used in different scenarios.
50000 is used to emphasize that the handling of the initial problem by looping through the range instead of using an array gets much, much slower as more rows are in the range.
The first If Statement ensures that the range is contiguous, and the second one ensures that there are at least two columns in the range.
Issues
I'm not completely sure that the '.value' part in the first line is not needed, but the code worked fine so far. On the other hand the '.value' part in the second line is needed or empty cells will be transferred.
When there are formulas in the range, they will be lost i.e. values will be transferred instead.
I am trying to find a cell containing certain value in a different, closed file from where I am running my code. Once I find it, I want to receive the row number of said cell. Somehow my code won't work. It is a mixture of stuff I have found on this site and things I have coded myself. Any help would be great!
Dim file_dir As Workbook
Set file_dir = Workbooks.Open("PATH.xlsx")
Dim j As Integer
Dim n As Integer
Dim temp As Range
n = file_dir.ActiveSheet.Cells(file_dir.ActiveSheet.Cells.Rows.Count, "A").End(xlUp).Row
Set temp = file_dir.ActiveSheet.Range("A1:A" & n).Find(what:="LOOKUP_VALUE")
j = temp.Row
MsgBox j
Welcome to Stack Overflow, I can see you are a beginner so I thought I would show a different way of solving this. You need to learn the data types and what functions return so I think instead of using nested functions etc it is better to start off with a simpler code and then you can make it more sophisticated by making it run faster etc. It seems your value is in column A so instead of using FIND just loop and compare it to your lookup_value. Make sure that you give the lookup_value a real value inside the routine:
Sub Main()
Dim bValueFound As Boolean
Dim j As Integer
Dim n As Integer
Dim temp As Range
Dim WS As Worksheet
Dim file_dir As Workbook
Set file_dir = Workbooks.Open("PATH.xlsx")
Set WS = file_dir.ActiveSheet
n = WS.Cells(WS.Cells.Rows.Count, "A").End(xlUp).Row
Set temp = file_dir.ActiveSheet.Range("A1:A" & n)
For j = 1 To n
If WS.Cells(j, 1).Value = LOOKUP_VALUE Then
bValueFound = True
Exit For
End If
Next j
If bValueFound Then
MsgBox "The row is " & j
Else
MsgBox "Lookup value was not found"
End If
End Sub
I am looping through a row of cells and trying to assign the values in these cells to an array, but this is resulting in a Type Mismatch error. The relevant bits of my code are below:
Dim queryaddress As Range
Dim notoffsetnum As Integer
Dim anotherarrayofnumbers() As Integer
Dim c As Range
For Each queryaddress In worksheetname.Range("B2:B21")
Set queryrow = queryaddress.EntireRow
notoffsetnum = 0
For Each c In queryrow
If c.Interior.Color <> 192 And Not IsEmpty(c.Value) Then
notoffsetnum = notoffsetnum + 1
ReDim Preserve anotherarrayofnumbers(notoffsetnum)
anotherarrayofnumbers(notoffsetnum) = c.Value
'The above line errors
End If
Next c
Next queryaddress
A for each loop loops through a collection. You have a range called query row. You have a range called c. What you've done is loop through every RANGE in queryrow...which means c will just be query row.
You want
for each c in queryrow.cells
Also, be aware that's about as inefficient as possible since it's going to loop through all 65000 or so columns, instead of just the comparatively few that actually have data.
EDIT: I'm not sure why that's still getting you an error. You have other logical errors though. This executes for me (also, for the love of goodness, indenting!), if I throw in some data from B2:H21, for example:
Sub test()
Dim worksheetname As Worksheet
Set worksheetname = ActiveWorkbook.ActiveSheet
Dim queryaddress As Range
Dim notoffsetnum As Integer
Dim anotherarrayofnumbers() As Integer
Dim c As Range
For Each queryaddress In worksheetname.Range("B2:B21")
Dim queryrow As Range
Set queryrow = queryaddress.EntireRow
notoffsetnum = 0
For Each c In queryrow.Cells
If c.Interior.Color <> 192 And Not IsEmpty(c.Value) Then
notoffsetnum = notoffsetnum + 1
ReDim Preserve anotherarrayofnumbers(notoffsetnum)
anotherarrayofnumbers(notoffsetnum - 1) = c.Value
End If
Next c
Next queryaddress
Dim i As Integer
For i = 0 To UBound(anotherarrayofnumbers) - 1
Debug.Print anotherarrayofnumbers(i)
Next i
End Sub
One other problem that was easy to fix is that be default, VBA arrays are 0-based. They start at 0, and you were erroneously starting at 1. VBA won't throw an error, it'll just have element 0 be 0.
Your real problem is that after every row, you knock out the old array because notoffsetnum goes back to 0, and then you redim the array back to a size of 1. That throws away everything and at the end you've just got the last row. I ASSUME that's an error. Since this is something that comes up a lot, here's something that I think is a bit cleaner, and a little less brittle. The only assumption I make is that you start in B2, and that you have data going both down and to the right. If that's ever going to be a problem you can alter it a bit. I just think you'll find the range.end(xl...) methods a lifesaver. It takes you the cell you'd get if you pressed ctrl+arrow key, so it's a fast way to tease out the edges of ranges.
Sub BetterSolution()
Dim ws As Worksheet
Set ws = ActiveWorkbook.ActiveSheet
Dim firstCell As Range
Set firstCell = ws.Range("B2")
Dim lastCol As Integer
lastCol = firstCell.End(xlToRight).Column
Dim lastRow As Integer
lastRow = firstCell.End(xlDown).Row
Dim lastCell As Range
Set lastCell = ws.Cells(lastRow, lastCol)
Dim arr() As Integer
Dim rng As Range
Dim index As Integer
index = 0
For Each rng In ws.Range(firstCell, lastCell).Cells
index = index + 1
ReDim Preserve arr(index + 1)
arr(index) = rng.Value
Next rng
End Sub
The problematic bit of my code was this:
Dim anotherarrayofnumbers() As Integer
This led to an error on:
anotherarrayofnumbers(notoffsetnum) = c.Value
This was because some of my c.Value values were not actually integers.
One way to solve this is changing the array to the Variant type:
Dim anotherarrayofnumbers() As Variant
But this did not work for me as I later had to perform integer operations (such as WorksheetFunction.Quartile) on the array. Instead I simply applied formatting to those c.Value values that were not integer values, so as to filter them out of my array. This resolved my issues.
So my conditional on the If block now looks like this:
If c.Interior.Color <> 192 And c.Interior.Color <> 177 And Not IsEmpty(c.Value) Then
Where the additional interior color is what I formatted the non-integer values as.
So I've been having an issue with this script and was wondering if anyone could point me in the right direction to fix it.
I'm trying to scan a cell range and find the value of "X", which also has to align with the array (which seems to be working) that finds a value in another range of columns that is greater than 7.
Option Explicit
Private Sub Worksheet_Activate()
Dim ws As Worksheet
Dim lRow As Long
Dim rng As Range
Dim Checks As Variant
Dim RiskName As Variant
Dim Level As Integer
Dim ThreatAgent As Variant
Dim Vulns As Variant
Dim X As Integer
Dim Y As Integer
Dim impactRange As Range
Dim impactCell As Range
Dim checksRange As Range
Dim checksCell As Range
Me.UsedRange.Offset(17).ClearContents
X = 2
Y = 1
With Sheets("TA & Vul Combinations")
.AutoFilterMode = False
Set impactRange = .Range("R3:R50")
For Each impactCell In impactRange.Cells
If impactCell.Cells > 7 And Not IsEmpty(impactCell.Cells) Then
impactCell.Copy
Sheets("temp").Range("B" & X).PasteSpecial xlPasteValues
X = X + 1
Else
End If
Next impactCell
Set checksRange = .Range("E3:E50")
For Each checksCell In checksRange.Cells
If checksCell.Cells("E3") = "X" Then
checksCell.Copy
Sheets("temp").Range("C2:AO2").PasteSpecial xlPasteValues
Else
Range("K1") = "You Broke It"
End If
Next checksCell
.AutoFilterMode = False
End With
End Sub
If anyone could give me some tips that would be great
This line is wrong:
If checksCell.Cells("E3") = "X" Then
since you are using Cells property incorrectly.
Cells property only accepts numeric arguments.
Syntax: Cells(rowindex,colindex)
Examples:
Cells(1,1) 'refers to Range("A1")
Cells(1) 'refers to Range("A1")
However, you can also use letters for Columns like this:
Cells(1,"A") 'refers to Range("A1")
Btw, this will work though.
If checksCell.Range("E3") = "X" Then
But take note of the implications.
When you use Range.Range syntax, what happens is that you use a Relative Reference on your first range.
Example1:
Range("B2").Range("E3").Address
will give you $F$4 because that is the 5th (E) column and 3rd (3) row from B2.
Other Examples:
Range("C1:E10").Range("B2").Address 'refers to $D$2
Range("C1:E10").Range("A1:B3").Address 'refers to $C$1:$D$3
Hope this clear things up a bit.
I don't know exactly what you want to achieve in your code, so I will not provide corrections.
I can only tell why you are getting errors.
If you need additional help, revise your question and clear major things up.
Re this line, which is probably the one where your error lies (it's the only if equals line in the code block):
If checksCell.Cells("E3") = "X" Then
I'm pretty certain checksCell is already a cell from doing a for each on the range checksRange, so I'm not sure that applying .Cells("E3") to it is the right thing to do, or even a sane thing to do :-)
I would think the correct way would be:
If checksCell.Value = "X" Then