wht i want is if cell value in column A is 60 then cell value in the same row in column C must equal FF code below.
Sub column_check2()
Dim c As Range
Dim alastrow As Long
Dim clastrow As Long
alastrow = ActiveSheet.Cells(Rows.Count, 3).End(xlUp).Row
clastrow = ActiveSheet.Cells(Rows.Count, 3).End(xlUp).Row
For Each c In Range("A2:A3" & alastrow & ",C2:C3" & clastrow)
If Not c.Value = "60" And c.Value = "FF" Then
MsgBox "error" & c.Address
End If
Next c
End Sub
You just need to loop through each value in Column A and check your criteria (Cell = 60). You can then adjust the value in Column C by using Offset to navigate 2 cells to the right from the current cell in the loop
Sub Looper()
Dim ws As Worksheet: Set ws = ThisWorkbook.Sheets("Sheet1") 'Update Sheet Name
Dim lr As Long, Target As Range
lr = ws.Range("A" & ws.Rows.Count).End(xlUp).Row
For Each Target In ws.Range("A2:A" & lr)
If Target = 60 Then
Target.Offset(0, 2) = "FF"
End If
Next Target
End Sub
Even better, consider the way you would likely do this manually. Filter Column A for your target value and then just modify the resultant cells in Column C. Recreating this in VBA results in a solution more efficient than a loop (the larger the data set, the larger the efficiency gains)
Sub Filter()
Dim ws As Worksheet: Set ws = ThisWorkbook.Sheets("Sheet1")
Dim lr As Long: lr = ws.Range("A" & ws.Rows.Count).End(xlUp).Row
ws.Range("A1:A" & lr).AutoFilter Field:=1, Criteria1:=60 'Filter
ws.Range("C2:C" & lr).SpecialCells(xlCellTypeVisible).Value = "FF" 'Apply Values
ws.AutoFilterMode = False 'Remove Filter
End Sub
Related
I am trying to write a macro that will look in column A on sheet1 and see if it is missing any values from column A on sheet2 or column A on sheet3. If it is missing have the value added to the bottom of the column A on sheet1. The same value may exist on sheet2 and sheet3 but it only needs to be represented once on sheet1.
I'm working with the code below.
Sub newRow()
Dim rngSh1 As Range, rngSh2 As Range, rngSh3 As Range, mySelSh2 As Range, mySelSh3 As Range
Dim lastRowSh1 As Long, lastRowSh2 As Long, lastRowSh3 As Long
Dim wb As Worksheet
Dim cell As Range
Set wb = ThisWorkbook
With wb
lastRowSh1 = Worksheets("Sheet1").Range("A" & .Rows.Count).End(xlUp).Row
lastRowSh2 = Worksheets("Sheet2").Range("A" & .Rows.Count).End(xlUp).Row
lastRowSh3 = Worksheets("Sheet3").Range("A" & .Rows.Count).End(xlUp).Row
Set rngSh1 = Worksheets("Sheet1").Range("A1:A" & lastRowSh1)
Set rngSh2 = Worksheets("Sheet2").Range("A1:A" & lastRowSh2)
Set rngSh3 = Worksheets("Sheet3").Range("A1:A" & lastRowSh3)
End With
For Each cell In rngSh2.Cells
If IsError(Application.Match(cell.Value, rngSh1, 0)) Then
If mySelSh2 Is Nothing Then
Set mySelSh2 = cell
Else
Set mySelSh2 = Union(mySelSh2, cell)
End If
End If
Next cell
If Not mySelSh2 Is Nothing Then mySelSh2.Copy Destination:=Worksheets("Sheet1").Range("A" & lastRowSh1 + 1)
For Each cell In rngSh3.Cells
If IsError(Application.Match(cell.Value, rngSh1, 0)) Then
If mySelSh3 Is Nothing Then
Set mySelSh3 = cell
Else
Set mySelSh3 = Union(mySelSh3, cell)
End If
End If
Next cell
If Not mySelSh3 Is Nothing Then mySelSh3.Copy Destination:=Worksheets("Sheet1").Range("A" & lastRowSh1 + 1)
End Sub
I've made every adjustment I can think of but with every change I make I get a different error.
Any help would be greatly appreciated. Thanks!
Save yourself a little bit of time using a Scripting.Dictionary:
Option Explicit
Sub test()
Dim dict As New Scripting.dictionary, sheetNum As Long
For sheetNum = 2 To Sheets.Count
With Sheets(sheetNum)
Dim lastRow As Long: lastRow = .Cells(.Rows.Count, 1).End(xlUp).Row
Dim rowNum As Long
For rowNum = 1 To lastRow
Dim dictVal As Long: dictVal = .Cells(rowNum, 1).Value
If Not dict.Exists(dictVal) Then dict.Add dictVal, 0
Next rowNum
End With
Next sheetNum
With Sheets(1)
Dim checkableRangeLastRow As Long: checkableRangeLastRow = .Cells(.Rows.Count, 1).End(xlUp).Row
Dim checkableRange As Range: Set checkableRange = .Range(.Cells(1, 1), .Cells(checkableRangeLastRow, 1))
Dim dictKey As Variant
For Each dictKey In dict.Keys
If IsError(Application.Match(dictKey, checkableRange, 0)) = True Then
lastRow = .Cells(.Rows.Count, 1).End(xlUp).Row
.Cells(lastRow + 1, 1).Value = dictKey
End If
Next dictKey
End With
End Sub
You add all values in your not-master-sheet into dict then loop through that list; if it's not found in your master-sheet, then you add then to the end of the list.
A significant note is that the Type of value used as the dictVal may cause the IsError() statement to always be True if it is not the same Type as the data being assessed in the checkableRange.
As you see on the above picture, I need to use AutoFilter to show rows contains specific value e.g 102.
With Excel interface , I cannot use the criteria value 102 on Columns “B” & “C” on the same time.
I want to maintain the sort and structure of my dataset.
As a workaround, is it possible to show rows contains value 102 on Columns “B” & “C” and hide the other rows in between.
In advance I am grateful for all your help.
Sub Filter_criteria()
Dim ws As Worksheet
Set ws = ThisWorkbook.ActiveSheet
Dim rng As Range
Set rng = ws.Range("A2:R" & ws.Cells(Rows.Count, "A").End(xlUp).Row)
If Not ws.AutoFilterMode Then rng.AutoFilter 'Set AutoFilter if not already set
rng.AutoFilter Field:=2, Criteria1:="*102*", Operator:=xlAnd
End Sub
Please, test the next adapted code. It firstly, apply a filter on the second column, then unhide rows if the third column contains criteria:
Sub Filter_criteria()
Dim ws As Worksheet: Set ws = ThisWorkbook.ActiveSheet
Const crit As String = "*102*"
If ws.AutoFilterMode Then ws.AutoFilterMode = False
Dim rng As Range: Set rng = ws.Range("A1:R" & ws.cells(rows.count, "A").End(xlUp).row)
'place the first filter in second column:
rng.AutoFilter field:=2, Criteria1:=crit, Operator:=xlFilterValues
'unhide according to the third column, by iteration:
For i = 1 To rng.rows.count
If rng.cells(i, 3).Value Like crit Then rng.rows(i).Hidden = False
Next i
End Sub
A second version follows somehow BibBen's suggestion. The code builds an array as result of B:B and C:C concatenation and drop its content after the last column (after R:R), then filter by it and clear at the end:
Sub evaluateConcat()
Dim ws As Worksheet, lastR As Long, lastCol As Long, rng As Range, arr
Const crit As String = "*102*"
Set ws = ActiveSheet
If ws.AutoFilterMode Then ws.AutoFilterMode = False
lastR = ws.Range("A" & ws.rows.count).End(xlUp).row
lastCol = ws.cells(1, ws.Columns.count).End(xlToLeft).Column
Set rng = ws.Range("A1:S" & lastR)
'create an array as concatenation between columns B:B and C:C
arr = Evaluate(ws.Range("B2:B" & lastR).Address & "&" & ws.Range("C2:C" & lastR).Address)
With ws.cells(1, lastCol + 1)
.Value = "ConcCol" 'header
.Offset(1).Resize(UBound(arr), 1).Value = arr 'drop the array content after the last column
End With
rng.AutoFilter field:=lastCol + 1, Criteria1:=crit, Operator:=xlFilterValues 'filter by the above built column
ws.Columns(lastCol + 1).ClearContents 'clear the content of the added column
End Sub
Edited:
A third version will iterate between the two columns keeping criteria, placed in an array and build a Union range (of not matching criteria) to be finally hidden:
Sub FilterByTwoCols()
Dim ws As Worksheet, lastR As Long, arr, i As Long, HdRng As Range
Const crit As String = "*102*"
Set ws = ThisWorkbook.ActiveSheet
ws.UsedRange.EntireRow.Hidden = False 'make all rows visible
lastR = ws.Range("A" & ws.rows.count).End(xlUp).row
arr = ws.Range("B2:C" & lastR).Value2 'place the relevant columns in an array for faster iteration
For i = 1 To UBound(arr)
If Not arr(i, 1) & arr(i, 2) Like crit Then
addToRange HdRng, ws.Range("A" & i + 1) 'make a Union range of the rows NOT matching criteria...
End If
Next i
If Not HdRng Is Nothing Then HdRng.EntireRow.Hidden = True 'hide not matching criteria rows.
End Sub
Private Sub addToRange(rngU As Range, rng As Range)
If rngU Is Nothing Then
Set rngU = rng
Else
Set rngU = Union(rngU, rng)
End If
End Sub
I want to calculate the Average of column Q and place the answer 2 cells below the last value in column Q. The code I'm using performs the calculation and gives me the average of the values between Q2 and the end of column Q if I insert a msgbox but I can't get it to put the answer into the correct cell.
Sub AverageRates()
With ActiveSheet
'Determine last row
Dim lastRow As Long
Dim cellRange As Range
Dim myAvg As Double
lastRow = .Cells(.Rows.Count, "D").End(xlUp).Row
'Average rate calculation
myAvg = Application.WorksheetFunction.Average(Range("Q1:Q" & lastRow))
Range("Q2:Q" & lastRow).Value = myAvg
'place the calculated average value 2 cells below the last cell in column Q
Set cellRange = Range("Q" & Lastrow").offset(2,0).select
End With
End Sub
You were pretty close ... try:
Option Explicit
Sub AverageRates()
Dim lastRow As Long
Dim myAvg As Double
With ActiveSheet
lastRow = .Cells(.Rows.Count, "Q").End(xlUp).Row
myAvg = Application.WorksheetFunction.Average(Range("Q1:Q" & lastRow))
Range("Q" & lastRow).Offset(2, 0).Value = myAvg
End With
End Sub
For a multi-column answer, assuming the columns are not equal in length (if so, then you could use an approach like #BigBen suggests), then you could do something like:
Sub AverageRates2()
Dim mySheet As Worksheet
Dim myColumn As Range
Dim myDataSet As Range
Dim lastRow As Long
Dim myAvg As Double
Set mySheet = ActiveSheet
For Each myColumn In mySheet.Range("J:Q").Columns
lastRow = mySheet.Cells(mySheet.Rows.Count, myColumn.Column).End(xlUp).Row
myAvg = Application.WorksheetFunction.Average(myColumn.Rows(1).Resize(lastRow, 1))
myColumn.Rows(lastRow).Offset(2, 0).Value = myAvg
Next
End Sub
Part 1: Check if column B values exist in column C. If yes then change the font of the string in column B to Bold.
Part 2: I've used the code below and it worked well. Never tried it with 50k rows.
Sub matching()
LastRow = Sheet1.Cells(Rows.Count, 2).End(xlUp).Row
Application.ScreenUpdating = False
For x = 1 To LastRow
'Column B = Username
If Sheet1.Range("B" & x).Font.Bold = True Then Sheet1.Range("A" & x).Value = "yay"
Next x
Application.ScreenUpdating = True
End Sub
If you have to handle too many rows, is better to use Dictionary to store values of column C & use Array to store values in column B.
Notes:
Add "Microsoft Scripting Runtime" reference (Tools - References - "Microsoft Scripting Runtime")
Dictionary is case sensitive.
You may need to change the sheet name in line Set ws = ThisWorkbook.Worksheets("Sheet1") to fulfill your needs
You could try:
Option Explicit
Sub matching()
Dim ws As Worksheet
Dim dict As Scripting.Dictionary
Dim LastRowB As Long, LastRowC As Long, Count As Long, x As Long
Dim rng As Range, cell As Range
Dim arr As Variant
Set ws = ThisWorkbook.Worksheets("Sheet1")
Set dict = New Scripting.Dictionary
Application.ScreenUpdating = False
With ws
'Find the lastrow of column B
LastRowB = .Cells(.Rows.Count, "B").End(xlUp).Row
'Find the lastrow of column C
LastRowC = .Cells(.Rows.Count, "C").End(xlUp).Row
'Set an array with the values in column B - We assume that values start from row 1
arr = .Range("B1:B" & LastRowB)
'Set the range of the dicitonary - We assume that values start from row 1
Set rng = .Range("C1:C" & LastRowC)
Count = 0
'Loop range and create a dictionary with th eunique values
For Each cell In rng
If Not dict.Exists(cell.Value) Then
dict.Add Key:=cell.Value, Item:=Count
Count = Count + 1
End If
Next cell
'Loop the array & bold
For x = LBound(arr) To UBound(arr)
If dict.Exists(arr(x, 1)) Then
.Range("B" & x).Font.Bold = True
End If
Next x
End With
Application.ScreenUpdating = True
End Sub
Here you go.
Sub bold()
Dim lastrow As Double
Dim cel As Range
lastrow = Sheet1.Cells(Rows.Count, 1).End(xlUp).Row
For Each cel In Range("B1" & ":B" & lastrow)
If Not ActiveSheet.Range("C:C").Find(cel.Value) Is Nothing Then cel.Font.bold = True
Next cel
End Sub
I have a range of cells (dynamic number of rows) that I want to copy over starting with A1 cell. The below code isn't working for me as it is not moving the entire range of cell values from current location to A1. Please advise.
Range("E:E").Cut Range("A1")
Example,
If range in E is 50 rows, the cut and move should start at A1 and end at A50.
If range in E is 999 rows, the cut and move should start at A1 and end at A999.
As per your comment above, see below code:
Sub CutPaste()
Dim i As Long
Dim sRow As Long, eRow As Long
Dim ws As Worksheet
Set ws = Sheets("Sheet1")
'set the last row of data
eRow = ws.Range("E" & ws.Rows.Count).End(xlUp).Row
'find the start row of data
For i = 1 To eRow
If ws.Range("E" & i).Value <> "" Then
sRow = i
Exit For
End If
Next i
'now cut and paste
ws.Range("E" & sRow, "E" & eRow).Cut ws.Range("A1").Paste
'clear clipboard and object
Application.CutCopyMode = False
Set ws = Nothing
End Sub
This should work for you:
Sub Kopy()
Dim N As Long
N = Cells(Rows.Count, "E").End(xlUp).Row
Range("E1:E" & N).Cut Range("A1")
End Sub
NOTE:
You do not need to specify the same dimensions for the destination. A single cell will do.
Before:
and after: