Quick question, below is code snippet of a comparison program that checks two worksheets to find mismatching data. I would like to highlight or format the mismatching cells on the sheet4 but am running into syntax or maybe logic trouble. Any guidance would be greatly appreciated.
Option Explicit
Sub compare2WorkSheets()
Dim varSheetA As Variant, varSheetB As Variant
Dim strRangeToCheck As String
Dim iRow As Long, iCol As Long
strRangeToCheck = "A1:AB17000"
Debug.Print Now
varSheetA = Worksheets("Sheet3").Range(strRangeToCheck)
varSheetB = Worksheets("Sheet4").Range(strRangeToCheck)
Debug.Print Now
For iRow = LBound(varSheetA, 1) To UBound(varSheetA, 1)
For iCol = LBound(varSheetA, 2) To UBound(varSheetA, 2)
If varSheetA(iRow, iCol) = varSheetB(iRow, iCol) Then
' matching cells no format
Else
' mismatch found,format the Sheet4 cells to yellow
varSheetB(iRow, iCol).Interior.Color = vbYellow '...referencing syntax trouble
End If
Next iCol
Next iRow
End Sub
Another approach:
Sub CompareRanges()
Dim rngA As Range, rngB As Range, arr, r As Long, c As Long
Set rngA = Range("A1:D4")
Set rngB = Range("A6:D9")
'will be evaluated as an array formula
arr = ActiveSheet.Evaluate("=IF(" & rngA.Address & "=" & rngB.Address & ",1,0)")
For r = LBound(arr, 1) To UBound(arr, 1)
For c = LBound(arr, 2) To UBound(arr, 2)
If Not IsError(arr(r, c)) Then
rngA(r, c).Interior.Color = IIf(arr(r, c) = 0, vbYellow, vbWhite)
End If
Next c
Next r
End Sub
Here is a different approach that I typically use when trying to find and highlight mismatches. This should have the functionality you're looking for.
Option Explicit
Sub Compare2worksheets()
Dim iCol, iRow As Integer
For iCol = 1 To 27
For iRow = 1 To 17000
If Worksheets("Sheet3").Cells(iRow, iCol) = Worksheets("Sheet4").Cells(iRow, iCol) Then
'Do Nothing
Else
Worksheets("Sheet4").Cells(iRow, iCol).Interior.Color = vbYellow
End If
Next iRow
Next iCol
End Sub
Related
I need to set some keywords based on multiple columns. I currently use this code which works well for one column:
Dim Words As range
Set Words = Sheets("Words").range("A2").Resize(Sheets("Words").range("A" & Rows.Count).End(xlUp).Row - 1)
But if I extend this to, say, A:AT it doesn't work.
Basically all I want to do is store all the words in ranges A2:Ax all the way to AT2:ATx but the issue is that each column has a different number of words that need to be stored.
EDIT: As requested, my full code as it currently stands
Sub Keyword()
Application.ScreenUpdating = False
Dim Words As range
Dim strText As range
Dim c As range
Dim r As range
Set Words = Sheets("Words").range("A2:AT2").Resize(Sheets("Words").range("A" & Rows.Count).End(xlUp).Row - 1)
Set strText = Sheets("Verbatims").range("BJ2").Resize(Sheets("Verbatims").range("BJ" & Rows.Count).End(xlUp).Row - 1)
For Each c In strText
For Each r In Words
If InStr(1, UCase(c), UCase(r), 1) > 0 Then
c.Offset(, 29) = c.Offset(, 29) & ", " & r
End If
Next r
If Len(c.Offset(, 29)) > 0 Then c.Offset(, 29) = Right(c.Offset(, 29), (Len(c.Offset(, 29)) - 2))
Next c
Application.ScreenUpdating = True
End Sub
EDIT2: Thanks to #jamheadart I've updated my code and it works now.
Sub Keywords()
Dim WordsRange As range
Dim hRow As Long
Dim i As Long
With Worksheets("Words")
For i = 1 To 46
If hRow < Cells(Rows.Count, i).End(xlUp).Row Then hRow = Cells(Rows.Count, i).End(xlUp).Row
Next i
Set WordsRange = range("A2:AT" & hRow)
End With
Dim c As range
Dim Words As Collection
Set Words = New Collection
For Each c In WordsRange
If c.Value <> "" Then Words.Add c.Value
Next
Dim strText As range
Dim x As range
Dim r As Variant
Set strText = Sheets("Verbatims").range("BJ2").Resize(Sheets("Verbatims").range("BJ" & Rows.Count).End(xlUp).Row - 1)
For Each x In strText
For Each r In Words
If InStr(1, UCase(x), UCase(r), 1) > 0 Then
x.Offset(, 29) = x.Offset(, 29) & ", " & r
End If
Next r
If Len(x.Offset(, 29)) > 0 Then x.Offset(, 29) = Right(x.Offset(, 29), (Len(x.Offset(, 29)) - 2))
Next x
End Sub
I think you need to loop through columns 1 to 46 (AT) and find the maximum row, I wouldn't normally rely on UsedRange because it can sometimes not register updates on sheets but I suspect you aren't writing a massive long thread.
Sub eh()
Dim WordsRange As Range
Dim hRow As Long
Dim i As Long
For i = 1 To 46
If hRow < Cells(Rows.Count, i).End(xlUp).Row Then hRow = Cells(Rows.Count, i).End(xlUp).Row
Next i
Set WordsRange = Range("A2:AT" & hRow)
MsgBox (WordsRange.Address)
End Sub
Maybes you then want to put everything that's not a "" in to a list of key words to check against rather than checking against the range?
Dim c as Range
Dim Words as Collection
For Each c In WordsRange
If c.Value2 <> "" Then Words.Add c.Value2
Next
may be you're after this
Dim Words As Range
With Worksheets("Words")
With Intersect(.Range("A:AT"), .UsedRange)
Set Words = .Resize(.Rows.Count - 1).Offset(1, 0).SpecialCells(xlCellTypeConstants)
End With
End With
Try,
Dim Words As range
with workSheets("Words")
with intersect(.range("A:AT"), .usedrange)
Set Words = .resize(.rows.count-1, .columns.count).offset(1, 0)
end with
end with
If you want to avoid blanks, create a Union.
Dim Words As range, i as long
with workSheets("Words")
set words = .range(.cells(2, "A"), .cells(.rows.count, "A").end(xlup))
for i=2 to .columns("AT").column
set words = Union(words, .range(.cells(2, i), .cells(.rows.count, i).end(xlup))
next i
end with
To cycle through that Union you will likely have to deal with the Range.Areas property.
I'm writing a code to loop through an excel sheet and changing the text (in column B) to uppercase/lowercase, depending on the value of cell in column N on the same row.
Macros purpose:
loop through cells in column B starting at row 2 and changing the string from upper to lowercase or vice versa, depending on the value of the cell in column N (lowercase if value = 5, other cases text should be uppercase)
Code I've got so far:
Sub CAPS()
'
' CAPS Macro
'
Dim Rang As Integer
Dim j As Integer
j = 2
For Each N In Source.Range("N2:N10000") ' Do 10000 rows
Rang = Cells(j, 14)
If Rang = 5 Then
Cells(j, 2).Range("A1").Select
ActiveCell.Value = LCase$(ActiveCell.Text)
Else
ActiveCell.Value = UCase$(ActiveCell.Text)
j = j + 1
End If
Next N
End Sub
I'm a little bit stuck in the looping part, not really a clue how to fix the error(s) in the current code.
Thanks in advance :)
Sub CAPS()
'
' CAPS Macro
'
Dim N as long 'use long here as integer is limite to a 32b character
For N Is 2 to 10000 ' Do 10000 rows
If Cells(N, 14) = 5 Then
Cells(N, 2) = LCase(Cells(N,2)
Else
Cells(N, 2) = UCase(Cells(N,2)
EndIf
Next N
End Sub
This should do the trick, untested though.
You currently have a fixed number of rows you want to test. To optimize your code you could first check how many rows are filled with data. To do so you can use:
DIM lastrow as long
lastrow = Cells(Rows.Count, "B").End(xlUp).Row
And then make the loop with For N Is 2 to lastrow
Also it is good practice to explicitly reference your worksheets, as this prevents undesired results. For example you click on another worksheet whilst the code is running it will continue formatting on that sheet. To do so declare a variable as your worksheet:
DIM ws as worksheet
And set a value to your variable, in this case Sheet1.
Set ws as ThisWorkbook.Worksheets("Sheet1")
Now every time you reference a Cells(), you explicitly say on what sheet that has to be by adding ws. in front of it like such: ws.Cells()
To summarize all that into your code:
Sub CAPS()
'
' CAPS Macro
'
Dim N as long 'use long here as integer is limite to a 32b character
Dim lastrow as long
Dim ws as worksheet
Set ws = ThisWorkbook.Worksheets("Sheet1") 'Set the code to run on Sheet 1 of your current workbook.
lastrow = ws.Cells(Rows.Count, "B").End(xlUp).Row
For N Is 2 to lastrow ' Do all rows that have data in column B
If ws.Cells(N, 14) = 5 Then
ws.Cells(N, 2) = LCase(ws.Cells(N,2)
Else
ws.Cells(N, 2) = UCase(ws.Cells(N,2)
EndIf
Next N
End Sub
Try processing in an array,
Sub CAPS()
'
' CAPS Macro
'
Dim arr As variant, j As Integer
with worksheets("sheet1")
arr = .range(.cells(2, "B"), .cells(.rows.count, "B").end(xlup).offset(0, 12)).value2
for j= lbound(arr, 1) to ubound(arr, 1)
if arr(j, 13) = 5 then
arr(j, 1) = lcase(arr(j, 1))
else
arr(j, 1) = ucase(arr(j, 1))
end if
next j
redim preserve arr(lbound(arr, 1) to ubound(arr, 1), 1 to 1)
.cells(2, "B").resize(ubound(arr, 1), ubound(arr, 2)) = arr
end with
End Sub
You may try something like this...
Sub CAPS()
Dim ws As Worksheet
Dim lr As Long, i As Long
Application.ScreenUpdating = False
Set ws = Sheets("Sheet1") 'Sheet where you have to change the letter case
lr = ws.Cells(Rows.Count, "B").End(xlUp).Row
For i = 2 To lr
Select Case ws.Cells(i, "N")
Case 5
ws.Cells(i, "B") = LCase(ws.Cells(i, "B"))
Case Else
ws.Cells(i, "B") = UCase(ws.Cells(i, "B"))
End Select
Next i
Application.ScreenUpdating = True
End Sub
Another approach using for each loop with Range:
Sub UCaseLCase()
Dim rng, cell As Range
Dim Test As Integer
Test = 5
Set rng = Range(Cells(2, 14), Cells(10000, 14))
For Each cell In rng.Cells
If cell.Value = Test Then
cell.Offset(0, -12) = LCase(cell.Offset(0, -12))
Else
cell.Offset(0, -12) = UCase(cell.Offset(0, -12))
End If
Next cell
End Sub
I know you said in your question starting at row 2 but it's easier just going from last row until row 2.
Hope this can help or at least, learn something new about Loops :)
Sub CAPS()
Dim j As Integer
For j = Range("B2").End(xlDown).Row To 2 Step -1
If Range("N" & j).Value = 5 Then
'uppercase
Range("B" & j).Value = UCase(Range("B" & j).Value)
Else
'lowercase
Range("B" & j).Value = LCase(Range("B" & j).Value)
End If
Next j
End Sub
I have a value in column C which in some cases are duplicated, where there are duplicates I want it to look in column Z for the corresponding ID if none exist I want it to check where whether any other values in column C have a value in Column Z and then add the missing values into column Z accordingly:
Column C Column Z
45519 Blank*
45519 1
456 2
456 *Blank
Expected result:
Column C: Column Z
45519 1
45519 1
456 2
456 2
Stackoverflow Code I have adapted to use 1 and 24 respectively.
Sub test()
Dim wb As Workbook
Set wb = ThisWorkbook
Dim ws As Worksheet
Set ws = ThisWorkbook.Worksheets("transactions")
lastRow = ws.Cells(ws.Rows.Count, "C").End(xlUp).Row
Dim dataArr()
dataArr = ws.Range("C1:Z" & lastRow).Value
Dim currentRow As Long
Dim dict As Object
Set dict = CreateObject("Scripting.Dictionary")
For currentRow = LBound(dataArr, 1) To UBound(dataArr, 2)
If Not IsEmpty(dataArr(currentRow, 2)) And Not dict.Exists(dataArr
(currentRow, 1)) Then
dict.Add dataArr(currentRow, 1), dataArr(currentRow, 2)
End If
Next currentRow
For currentRow = LBound(dataArr, 1) To UBound(dataArr, 1)
If IsEmpty(dataArr(currentRow, 2)) Then
dataArr(currentRow, 2) = dict(dataArr(currentRow, 1))
End If
Next currentRow
ws.Range("C1").Resize(UBound(dataArr, 1), UBound(dataArr, 2)) = dataArr
End Sub
I am receiving no result in column Z as a result of this
Try this. Amended column references as per comments, plus I think your first loop was unnecessarily long. You'll need to change the 24s if your array is actually of a different size.
Option Explicit
Sub test()
Dim wb As Workbook
Set wb = ThisWorkbook
Dim ws As Worksheet
Dim lastRow As Long
Set ws = ThisWorkbook.Worksheets("transactions")
lastRow = ws.Cells(ws.Rows.Count, "C").End(xlUp).Row
Dim dataArr()
dataArr = ws.Range("C1:Z" & lastRow).Value
Dim currentRow As Long
Dim dict As Object
Set dict = CreateObject("Scripting.Dictionary")
For currentRow = LBound(dataArr, 1) To UBound(dataArr, 1)
If Not IsEmpty(dataArr(currentRow, 24)) And Not dict.Exists(dataArr(currentRow, 1)) Then
dict.Add dataArr(currentRow, 1), dataArr(currentRow, 24)
End If
Next currentRow
For currentRow = LBound(dataArr, 1) To UBound(dataArr, 1)
If IsEmpty(dataArr(currentRow, 24)) Then
dataArr(currentRow, 24) = dict(dataArr(currentRow, 1))
End If
Next currentRow
ws.Range("C1").Resize(UBound(dataArr, 1), UBound(dataArr, 2)) = dataArr
End Sub
Alternative method
Sub test()
Dim wb As Workbook
Set wb = ThisWorkbook
Dim ws As Worksheet
Dim lastRow As Long
Set ws = ThisWorkbook.Worksheets("transactions")
lastRow = ws.Cells(ws.Rows.Count, "C").End(xlUp).Row
Dim r As Range, r1 As Range, s As String
For Each r In ws.Range("Z1:Z" & lastRow).SpecialCells(xlCellTypeBlanks)
Set r1 = ws.Range("C1:C" & lastRow).Find(ws.Cells(r.Row, "C"), , , xlWhole)
If Not r1 Is Nothing Then
s = r1.Address
Do Until r1.Row <> r.Row
Set r1 = ws.Range("C1:C" & lastRow).FindNext(r1)
If r1.Address = s Then Exit Do
Loop
r.Value = ws.Cells(r1.Row, "Z")
End If
Next r
End Sub
There is some tidying up to do. Currently assumes data starts in row 2.
Option Explicit
Public Sub test()
Dim wb As Workbook
Set wb = ThisWorkbook
Dim ws As Worksheet
Set ws = ThisWorkbook.Worksheets("transactions")
Dim lastRow As Long
lastRow = ws.Cells(ws.Rows.Count, "C").End(xlUp).Row
Dim unionRng As Range
Set unionRng = Union(ws.Range("C2:C" & lastRow), ws.Range("Z2:Z" & lastRow))
Dim dataArray()
Dim numberOfColumns As Long
numberOfColumns = unionRng.Areas.Count
ReDim dataArray(1 To lastRow, 1 To numberOfColumns) '1 could come out into variable startRow
Dim currRow As Range
Dim columnToFill As Long
For columnToFill = 1 To numberOfColumns
For Each currRow In unionRng.Areas(columnToFill)
dataArray(currRow.Row - 1, columnToFill) = currRow 'assume data starts in row 1 otherwise if 2 then currRow.Row -1 etc
Next currRow
Next columnToFill
Dim currentRow As Long
Dim dict As Object
Set dict = CreateObject("Scripting.Dictionary")
For currentRow = LBound(dataArray, 1) To UBound(dataArray, 1)
If Not IsEmpty(dataArray(currentRow, 2)) And Not dict.Exists(dataArray(currentRow, 1)) Then
dict.Add dataArray(currentRow, 1), dataArray(currentRow, 2)
End If
Next currentRow
For currentRow = LBound(dataArray, 1) To UBound(dataArray, 1)
If IsEmpty(dataArray(currentRow, 2)) Then
dataArray(currentRow, 2) = dict(dataArray(currentRow, 1))
End If
Next currentRow
ws.Range("Z2").Resize(UBound(dataArray, 1), 1) = Application.Index(dataArray, 0, 2)
End Sub
you could very simply go like follows
Option Explicit
Sub main()
Dim cell As Range, IdsRng As Range
With Worksheets("transactions") 'reference wanted sheet
Set IdsRng = .Range("Z2", .Cells(.Rows.Count, "Z").End(xlUp)).SpecialCells(XlCellType.xlCellTypeConstants, xlNumbers) 'get all IDs from its column Z cells with constant numeric value
With .Range("C1", .Cells(.Rows.Count, "C").End(xlUp)) 'reference referenced sheet column C cells from row 1 (header) down to last not empty one
For Each cell In IdsRng 'loop through all IDs
.AutoFilter Field:=1, Criteria1:=cell.Offset(, -23).value ' filter referenced cells on 1st column with passed ID content 'filter referenced range with current ID
.Offset(1, 23).Resize(.Rows.Count - 1).SpecialCells(xlCellTypeVisible).value = IdsRng.value 'write all filtered cells corresponding values in column Z with current ID
Next
End With
.AutoFilterMode = False
End With
End Sub
Sub listClean()
For Each cellA In Range("A:A")
If cellA.Value <> "" Then
For Each cellB In Range("B:B")
If cellB.Value <> "" Then
If StrComp(cellA.Value, cellB.Value) = 0 Then
cellA.Value = ""
End If
End If
Next
End If
Next
MsgBox "Macro Finished"
End Sub
The code basically removes from Range A:A whatever is in range B:B.
Is there anything I can do to speed up this macro? I was thinking VBA could have a way to make ranges into arrays, and then clean the arrays.
This should be very quick.
It uses arrays instead of looping through the ranges.
Sub listClean()
Dim i As Long, t As Long, mtch As Long
Dim aClm() As Variant, bClm() As Variant
Dim outArr() As Variant
ReDim outArr(1 To 1) As Variant
With ActiveSheet
'Load the arrays
aClm = .Range(.Cells(1, 1), .Cells(.Rows.Count, 1).End(xlUp)).Value
bClm = .Range(.Cells(1, 2), .Cells(.Rows.Count, 2).End(xlUp)).Value
t = 0
For i = 1 To UBound(aClm, 1)
mtch = 0
'Search for match. If no match found it will error and stay at 0
On Error Resume Next
mtch = Application.WorksheetFunction.Match(aClm(i, 1), bClm, 0)
On Error GoTo 0
'Test whether match was found.
If mtch = 0 Then
t = t + 1
'make output array bigger.
ReDim Preserve outArr(1 To t) As Variant
'Load value into last spot in output array
outArr(t) = aClm(i, 1)
End If
Next i
'Assign values to range from array.
.Range("C1").Resize(UBound(outArr, 1), 1).Value = Application.Transpose(outArr)
End With
MsgBox "Macro Finished"
End Sub
It does put the output in column C. If you want to put it in column A then change,
.Range("C1").Resize(UBound(outArr, 1), 1).Value = Application.Transpose(outArr)
to:
.Range(.Cells(1, 1), .Cells(.Rows.Count, 1).End(xlUp)).ClearContents
.Range("A1").Resize(UBound(outArr, 1), 1).Value = Application.Transpose(outArr)
Hello I am trying to copy a range into a single column. The range is a mix of blank cells and cells with values.I only want to copy and paste the cells with values and I would it to find the first blank cell and want it to walk itself down the column from there.
The code I have right now (besides taking forever) pastes in the first row.
Dim i As Integer
i = 1
ThisWorkbook.Worksheets("amount date").Select
For Row = 51 To 100
For col = 2 To 1000
If Cells(Row, col).Value <> "" Then
Cells(Row, col).Copy
Worksheets("sheet 2").Range("G" & i).PasteSpecial xlPasteValues
End If
Next
Next
Do While Worksheets("sheet 2").Range("G" & i).Value <> ""
i = i + 1
Loop
End Sub
This will work:
Sub qwerty()
Dim i As Long, r As Long, c As Long
i = 1
ThisWorkbook.Worksheets("amount date").Select
For r = 51 To 100
For c = 2 To 1000
If Cells(r, c).Value <> "" Then
Cells(r, c).Copy
Worksheets("sheet 2").Range("G" & i).PasteSpecial xlPasteValues
i = i + 1
End If
Next
Next
End Sub
Perhaps this will be a little faster (even though it seems to have been slow arriving).
Sub CopyRangeToSingleColumn()
' 20 Oct 2017
Dim LastRow As Long
Dim LastClm As Long
Dim Rng As Range, Cell As Range
Dim CellVal As Variant
Dim Spike(), i As Long
With ThisWorkbook.Worksheets("amount date")
With .UsedRange.Cells(.UsedRange.Cells.Count)
LastRow = Application.Max(Application.Min(.Row, 100), 51)
LastClm = .Column
End With
Set Rng = .Range(.Cells(51, "A"), .Cells(LastRow, LastClm))
End With
ReDim Spike(Rng.Cells.Count)
For Each Cell In Rng
CellVal = Trim(Cell.Value) ' try to access the sheet less often
If CellVal <> "" Then
Spike(i) = CellVal
i = i + 1
End If
Next Cell
If i Then
ReDim Preserve Spike(i)
With Worksheets("sheet 2")
LastRow = Application.Max(.Cells(.Rows.Count, "G").End(xlUp).Row, 2)
.Cells(LastRow, "G").Resize(UBound(Spike)).Value = Application.Transpose(Spike)
End With
End If
End Sub
The above code was modified to append the result to column G instead of over-writing existing cell values.
Do you need copy the whole row into one cell, row by row? For each loop shall be faster. I guess, this should work
Sub RowToCell()
Dim rng As Range
Dim rRow As Range
Dim rRowNB As Range
Dim cl As Range
Dim sVal As String
Set rng = Worksheets("Sheet3").Range("$B$51:$ALN$100") 'check this range
For Each rRow In rng.Rows
On Error Resume Next
Set rRowNB = rRow.SpecialCells(xlCellTypeConstants)
Set rRowNB = Union(rRow.SpecialCells(xlCellTypeFormulas), rRow)
On Error GoTo 0
For Each cl In rRowNB.Cells
sVal = sVal & cl.Value
Next cl
Worksheets("sheet4").Range("G" & rRow.Row - 50).Value = sVal
sVal = ""
Next rRow
End Sub
its quick for this range.