Excel countif vba code with criteria resulting with values - vba

I am not sure if what I want to achieve is possible. So here it is:
I got workbook with 2 sheets:
First sheet cointains raw data with employees and trainings they did or did not take (they could not come to the the training). Sheets cointains few columns like: name, special ID (different for every employee), 2 blank columns, presence (yes/no), and few more...
Second sheet will create report based on range and presence criteria.
Technically it's something like that:
Report sheet has list of employees, they will be filtered using autofilter. Those filtered employees will be checked if they were on 14 categories of trainings. Categories differs with range (ranges are known; with time ranges will be added or adjusted to newly added trainings).
My problem:
Is it possible to create vba code that will check if employee was on certain trainings (countif in certain range with condition: not present = do not count) and paste the value to certain cells? If it is could you give some advice on how to do that? I am not asking for ready code.
Trying to make it work but I stuck at this. Error at line "if cells.find...".
Sub Check()
MyRange = Range("A1", Selection.End(xlDown))
For Each MyCell In MyRange
With Range("pp2dni2007")
If Cells.Find(MyCell.Value) Is Nothing Then
Else
If ActiveCell.Value = ActiveCell.Offset(0, 3).Value Then
MyCell.Offset(0, 6).Value = 1
Else
MyCell.Offset(0, 6).Value = 0
End If
End If
End With
Next
End Sub
2nd edit, earlier code did infinite loop. Now I think if-statements reference to wrong range but not sure how to deal with it.
Sub Check()
Dim MyRange As Range, MyCell As Variant
Range("A1").Select
Set MyRange = Range(Selection, Selection.End(xlDown)).Rows.SpecialCells(xlCellTypeVisible)
For Each MyCell In MyRange.Cells
With Range("pp2dni2007")
If .Cells.Find(MyCell.Value) Is Nothing Then
Else
If .Cells.Find(MyCell.Value).Value = .Cells.Find(MyCell.Value).Offset(0, 3).Value Then
MyCell.Offset(0, 6).Value = 1
Else
MyCell.Offset(0, 6).Value = 0
End If
End If
End With
Next
End Sub
Sample workbook: https://dl.dropboxusercontent.com/u/7421442/sample%20workbook%20(1).xls

Declare all your variables, e.g.,
Dim MyRange as Range, MyCell as Range.
Without declaration, MyCell is variant data type, and that is why you're getting an Object Required error. Then do:
For Each MyCell In MyRange.Cells
Inside the With block, you may want to use (note the . in front of Cells):
If .Cells.Find(MyCell.Value) Is Nothing Then
Further, you will probably need to revise what you're doing with ActiveCell, since this is never changing which cell is active, I'm not sure it would give you the expected results. It is always preferable to avoid relying on Active and Select methods (except for to use them as user-input). INstead, work with the range objects directly.

Related

Excel VBA Type Mismatch with If function

I am very new to VBA and have been teaching myself for the last week. I have taken on a task that is maybe a bit to complex for me.
I have a document with columns A - AE
I need to go through this document and move information on to separate sheets, depending on what it is.
I am now trying to use an IF statement that needs to match 2 requirements before it moves the information. I can get each individual requirement to work but not both together as keep getting a Type Mismatch error.
I have no idea what i am doing wrong. Any help will be much appreciated.
Sub copyrows()
Dim Test As Range, Cell As Object
Set Test = Range("G2:Z4000") 'Substitute with the range which includes your True/False values
For Each Cell In Test
If IsEmpty(Cell) Then
Exit Sub
End If
If Cell.Value = "Refund" And "Commission" Then
Cell.EntireRow.Copy
Sheet3.Select 'Substitute with your sheet
ActiveSheet.Range("A65536").End(xlUp).Select
Selection.Offset(1, 0).Select
ActiveSheet.Paste
End If
Next
End Sub
If Cell.Value = "Refund" And "Commission" Then
Should instead read:
If Cell.Value = "Refund" Or Cell.Value = "Commission" Then
You have to be explicit with each condition separated by boolean operators like AND or OR.
The reason for your error is already mentioned in the answer above by #IanL
However, your code is far from being optimized.
You can replace your 5 lines:
Cell.EntireRow.Copy
Sheet3.Select 'Substitute with your sheet
ActiveSheet.Range("A65536").End(xlUp).Select
Selection.Offset(1, 0).Select
ActiveSheet.Paste
With 1:
Cell.EntireRow.Copy Destination:=Sheet3.Range("A65536").End(xlUp).Offset(1)
Which is not using Select, ActiveSheet, or Selection, just using fully qualified Range object.

VBA - Error when using ActiveCell and CurrentRegion

I'm trying to write a small piece of VBA that will shade a column of excel cells based on RGB variables in adjacent columns. So I have a table of data (no headings) with 3 columns (R G and B) and x rows (amount will vary). What I would like is to colour a 4th column to the right of this table in a colour based on the 3 numbers to the left. Note that I plan to select the top left cell each time I perform this.
Below is the code I have used but I get an error message:
Error 438... Object doesnt support this property or method
pointing to the Set rng line as being the problem.
Any thoughts or help much appreicated
Sub RGBTest()
Dim rng As Range
Dim n As Integer
Set rng = ActiveSheet.ActiveCell.CurrentRegion
ActiveCell.Offset(0, 3).Activate
For n = 1 To rng.Rows.Count
ActiveCell.Interior.Color = RGB(rng.Cells(n, 1), rng.Cells(n, 2), rng.Cells(n, 3))
ActiveCell.Offset(1, 0).Activate
Next n
End Sub
So the line
Set rng = ActiveSheet.ActiveCell.CurrentRegion
causes the error Error 438... Object doesnt support this property or method.
That means either ActiveSheet doesn't support .ActiveCell or ActiveCell doesn't support .CurrentRegion.
ActiveCell is a range and CurrentRegion is a property of Range so that shouldn't be it.
However, ActiveCell is not a property of a worksheet but of Application. That makes sense since there is only one active cell per Excel instance, not per sheet. So instead of
Set rng = ActiveSheet.ActiveCell.CurrentRegion
just use
Set rng = ActiveCell.CurrentRegion

Program code is deleting the data which I want to keep

I have a macro that consolidate the values on another sheet, and based on these values, it´s has to go back on the first sheet and delete. But the macro is deleting what I want to keep.
The sheet.
The Macro:
Sub DeleteOthers()
Dim r1 As Range, c As Range
Dim t As String
With Sheets("Sheet2")
Set r1 = .Range(.Cells(2, "H"), .Cells(Rows.Count, "H").End(xlUp))
End With
For Each c In r1
If c.Text = "<<<Keep Row" Then
Sheets("Sheet1").Select
t = c.Offset(0, -1)
Rows(t).ClearContents
End If
Next
End Sub
Change to:
If c.Text <> "<<<Keep Row" Then
#Vityata's answer gets right to the heart of the issue -- using <> instead of = is the chief issue here.
(Using #arcadeprecinct's recommendation of c.Value instead of c.Text is also a great idea.)
If you were to tackle this by hand in Excel, you probably wouldn't go line-by-line though -- right? You would use Excel's built-in filtering... and with VBA, you can get the same wonderful results in a hurry by using the Range object's built in AutoFilter method.
Option Explicit
Sub DeleteOthersWithAutoFilter()
Dim r1 As Range, c As Range
'Grab the full data range, not just column H
With Sheets("Sheet2")
Set r1 = .Range(.Cells(1, 1), .Cells(Rows.Count, "N").End(xlUp))
End With
With r1
'Apply the Autofilter method to column H in the range
'identifying any cells NOT containing "<<<Keep Row"
.AutoFilter Field:=8, _
Criteria1:="<><<<Keep Row"
'Clear the remaining, visible rows while keeping the headers
Set c = .Offset(1, 0).Resize(.Rows.Count - 1).SpecialCells(xlCellTypeVisible)
c.ClearContents
End With
'Clear the filter
Sheets("Sheet2").AutoFilterMode = False
End Sub
Using Range.AutoFilter instead of looping through individual rows can be very fast, especially as your data sets get larger.
You can learn more about the differences between the two strategies, looping through rows and Range.AutoFilter, here:
https://danwagner.co/how-to-delete-rows-with-range-autofilter/
Which includes a YouTube video benchmarking each in action.

Find non-static [value] and paste range (F1:G1) next to "found" cell - Excel VBA

I have a list of query words that I am submitting to a database (Column A) to generate a list of coded matches (Columns F-H). Column F is the original search word (so there is an exact match somewhere in Column A), Column G contains the match, and Column H contains the code for the match. What I need to do is take the query word in Column F and find its partner in Column A. Then I need to take the corresponding match and its code and paste it next to the original search term in Column A (in Columns B&C).
My problem here is getting the information pasted in the correct cell since the copy to and paste from locations change every time -- The list of coded matches in Columns F-H does NOT contain all of the terms in Column A.
I've been searching the internet and I can't seem to figure out what exactly I need to change to allow the paste function to work.
I have attached an image of a simplified version of my spreadsheet and a annotated version of the code I have been working with.
Sub FindMatch()
LastRow = Cells(Rows.Count, 6).End(xlUp).Row
For i = 1 To LastRow
FindMe = Cells(i, 6).Value
Set FoundinList = Cells.Find(What:=FindMe, After:=ActiveCell, LookAt:=xlWhole)
If Not FoundinList Is Nothing Then
FoundinList.Select
ActiveCell.Offset(0, 1).Select
'At this point the cell I want the information pasted into is selected. Yay!
'Example: I am trying to find "abnormal digits" (F1) in Column A and paste
'G1:H1 into the appropriate cells in Columns B & C (In this case B15:C15)
'At this point in the code my cursor is on cell B15 - which is where I need it.
Range(Cells(i, 7), Cells(i, 8)).Copy
'This selects the appropriate range (G1:H1 in my example).
ActiveCell.Paste
'This is the problem string. I've tried naming the "ActiveCell" before initiating the copy
'string (ActiveCell.Name = "PasteHere") and then pasting into the named cell
'(Cells("PasteHere").Paste), but that gives me an invalid procedure call or argument on:
'Cells("PasteHere").Paste I've also tried pasting into a range:Range(Cells(PasteHere, 2)
', Cells(PasteHere, 3)).Paste -AND- using the formula that is created when you a record a
'macro (Application.CutCopyMode = False) but both of those give me an application
'/object-defined error.
End If
Next i
End sub
Thank you so much in advance for reading this post and helping me out.
My Spreadsheet
End Product
This vba uses the worksheet function vlookup.
Sub ahhn()
Dim ws As Worksheet
Dim cel As Range
Set ws = ActiveSheet
With ws
For Each cel In .Range(.Range("A1"), .Range("A1").End(xlDown))
cel.Offset(0, 1) = WorksheetFunction.IfError(Application.VLookup(cel, .Range("F:H"), 2, 0), "")
cel.Offset(0, 2) = WorksheetFunction.IfError(Application.VLookup(cel, .Range("F:H"), 3, 0), "")
Next
End With
End Sub

How do I add “+1” to all cells in a user selected range?

I need to have the user select a range of cells with their mouse and then run a macro to add +1 to that selected range. The range will often be different every time, so it cannot be defined.
Here's what I have so far, it just works on a single active cell, I cannot get it to work on a range selection, because I do not know what to define or function to utilize.
My code Follows:
Sub Add()
ActiveCell.Value = ActiveCell.Value + 1
End Sub
The below code uses the built-in Paste Special Add feature to add 1 to every cell in the selected range.
Sub AddOneToSelection()
Dim rBlank As Range
If TypeName(Selection) = "Range" Then
'Put a '1' in an unused cell and copy it
Set rBlank = ActiveSheet.Cells.SpecialCells(xlLastCell).Offset(1, 0)
rBlank.Value = 1
rBlank.Copy
'Paste Special Add over the selection
Selection.PasteSpecial Paste:=xlPasteValues, _
Operation:=xlAdd
'Get rid of the copied cell
rBlank.ClearContents
End If
End Sub
The benefit of this over looping is that Paste Special Add treats formulas and values differently and you don't have to code that part yourself.
The downside is you increase your UsedRange by one row, if that matters to you.
This should work for you:
Dim r, c As Range
Set r = Selection
For Each c In r
c.Value = "+1"
Next
This assumes that your cell formats will display "+1" instead of "1". You can set the format of your cells to "Text".