I have been trying to code a countif function into a loop, however, I am having a little trouble with the outputs. Instead of reading a number when the computation occurs, the function keeps outputting "true" or "false". Maybe there is an error in my code, but I have used many countif functions in the past without experiencing a problem such as this. As you can see below, I tried to write the function in two different ways, but both either didn't work or outputted "true" or "false".
Please Help.
Sub CorrectSets()
Dim Cell As Range
Range("B100000").End(xlUp).Select
LastRow = ActiveCell.Row
For Each Cell In Range("S2:S" & LastRow)
StartTime = Cell.Offset(0, -12)
Shift = Cell.Offset(0, -14)
SortedOp = Cell.Offset(0, -17)
DOW = Cell.Offset(0, -5)
'Cell.Value = CountIF(E2:E & LastRow, Shift, N2:N & LastRow ,DOW, B2:B & LastRow,SortedOp, G2:G & LastRow, " < " & StartTime)
Cell.Value = "=CountIF(E2:E" & LastRow & ", " & Shift & ", N2:N" & LastRow & "," & DOW & ", B2:B" & LastRow & "," & SortedOp & ", G2:G" & LastRow & ", " < " " & StartTime & ")"
Next Cell
If you want to put a countif() Formula in Cell then:
Cell.Formula = "=CountIF(E2:E &...............
If you want to put the formula's result in Cell then:
Cell.Value = Application.Worksheetfunction.CountIF(E2:E &....................
You should use
Cell.Formula = "=CountIFs..."
or
Cell.Value = WorksheetFunction.CountIfs...
See official documentation.
Plus:
To find the last row containing data in a column (B in this case) use
Dim ws as Worksheet
Set ws = ActiveSheet
Dim LastRow as Long
LastRow = ws.Range("B" & ws.Rows.Count).End(xlUp).Row
ws is a reference to the Worksheet of interest (ActiveSheet in my example).
See this answer.
You'd rather fully qualify your ranges, and avoid using Select unless it is strictly needed.
With the code posted above,
Range("B100000").End(xlUp).Select
might not be needed.
If using Cell.Formula = "=CountIFs...", it might be convenient to use
Dim frm as String
frm = "=CountIFs..."
Cell.Formula = frm
for easier debugging.
Related
The background:
I have a workbook, Outline.xlsm, with a five-level hierarchy. In the first worksheet (WS1), the first three levels are described the first two columns, while the next two levels each have their own set of two columns:
In the second worksheet (WS2), there is no level 3, but everything else is the same. All cells are formatted as text.
I have some code that splits out each first-level section ("General thing") into its own workbook to allow users to make changes to the descriptions (and some other fields off to the right). The code in question then goes out and gets those new descriptions from each file and matches them to the ID number. Here is a sanitized version:
Option Explicit
Sub GatherData()
'Set up for speed
Application.ScreenUpdating = False
Application.EnableEvents = False
Application.Calculation = xlCalculationManual
'Get files to be processed
Dim DataFolder As String
Dim DataFile As String
DataFolder = "\\SomeNetworkLocation"
DataFile = Dir(DataFolder & "\GeneralThing*.xlsx")
'Define ranges to search
Dim WS1_L1Rng As Range
Dim L2rng As Range
Dim L3rng As Range
Set WS1_L1Rng = Worksheets("WS1").Range("A2", "A" & Range("N2").End(xlDown).Row)
Set L2rng = Worksheets("WS1").Range("C2", "C" & Range("N2").End(xlDown).Row)
Set L3rng = Worksheets("WS1").Range("E2", "E" & Range("N2").End(xlDown).Row)
Dim WS2_L1Rng As Range
Dim WS2_L2Rng As Range
Set WS2_L1Rng = Worksheets("WS2").Range("A2", "A" & Range("K2").End(xlDown).Row)
Set WS2_L2Rng = Worksheets("WS2").Range("C2", "C" & Range("K2").End(xlDown).Row)
Dim MatchPos As Variant
Dim WS1_SearchRng As Range
Dim WS2_SearchRng As Range
Dim Cell As Range
'Find and copy data
Do While DataFile <> ""
Workbooks.Open Filename:=DataFolder & "\" & DataFile
With Workbooks(DataFile).Worksheets("WS1")
Set WS1_SearchRng = .Range("A2:" & "A" & .Range("A" & .Rows.Count).End(xlUp).Row & ",C2:" & "C" & .Range("C" & .Rows.Count).End(xlUp).Row & ",E2:" & "E" & .Range("E" & .Rows.Count).End(xlUp).Row)
End With
For Each Cell In WS1_SearchRng
If IsNumeric(Left(Cell.Value2, 2)) Then
Select Case Cell.Rows.OutlineLevel
Case Is < 4
MatchPos = Application.Match(Cell.Value2, WS1_L1Rng, 0)
Case 4
MatchPos = Application.Match(Cell.Value2, L2rng, 0)
Case 5
MatchPos = Application.Match(Cell.Value2, L3rng, 0)
End Select
If IsError(MatchPos) Then
Debug.Print "WS1 " & Cell.Value2
Else
MatchPos = MatchPos + 1
Workbooks(DataFile).Worksheets("WS1").Range("A" & Cell.Row, "L" & Cell.Row).Copy Destination:=Workbooks("Outline.xlsm").Worksheets("WS1").Range("A" & MatchPos, "L" & MatchPos)
End If
End If
DoEvents
Next Cell
If Workbooks(DataFile).Worksheets.Count > 1 Then
With Workbooks(DataFile).Worksheets("WS2")
Set WS2_SearchRng = .Range("A2:" & "A" & .Range("A" & .Rows.Count).End(xlUp).Row & ",C2:" & "C" & .Range("C" & .Rows.Count).End(xlUp).Row)
End With
For Each Cell In WS2_SearchRng
If IsNumeric(Left(Cell.Value2, 2)) Then
Select Case Cell.Rows.OutlineLevel
Case Is < 4
MatchPos = Application.Match(Cell.Value2, WS2_L1Rng, 0)
Case 4
MatchPos = Application.Match(Cell.Value2, WS2_L2Rng, 0)
End Select
If IsError(MatchPos) Then
Debug.Print "WS2 " & Cell.Value2
Else
MatchPos = MatchPos + 1
Workbooks(DataFile).Worksheets("WS2").Range("A" & Cell.Row, "I" & Cell.Row).Copy Destination:=Workbooks("Outline.xlsm").Worksheets("WS2").Range("A" & MatchPos, "I" & MatchPos)
End If
End If
DoEvents
Next Cell
End If
With Workbooks(DataFile)
.Save
.Close
End With
DataFile = Dir
Loop
'Return to regular configuration
Application.ScreenUpdating = True
Application.EnableEvents = True
Application.Calculation = xlCalculationAutomatic
End Sub
The problem:
Often, when I go to run this code, Application.Match throws an error when it tries to match to anything in WS2. It usually works fine if I just kill the execution and start over on the same data (sometimes it takes a few tries). Very rarely, it can't find anything in WS1 either; again, if I simply restart the execution it usually works just fine. Sometimes everything works great on the first try. Why does it not behave consistently?
Watch for implicit references to the active workbook/worksheet; what workbook/worksheet these instructions are referring to at run-time will depend on whatever workbook/worksheet is active at that time, and this is often responsible for such errors.
You can use Rubberduck (an open-source VBIDE add-in project I manage) to easily locate them for you (and other potential code issues).
Range("N2") in Worksheets("WS1").Range("A2", "A" & Range("N2").End(xlDown).Row) would be one. Worksheets used unqualified with a Workbook object would be another.
The solution is to explicitly qualify them with a Workbook or Worksheet object reference.
I am having a fair amount of trouble with the code below:
Sub TestEmail()
Dim i As Long
Dim LastRow As Long
Dim a As Worksheet
Dim b As Worksheet
Dim strText
Dim ObjData As New MSForms.DataObject
Set a = Workbooks("Book2").Worksheets(1)
Set b = Workbooks("Book1").Worksheets(1)
LastRow = a.Cells(Rows.Count, "A").End(xlUp).Row
For i = 2 To LastRow
If Not IsError(Application.Match(a.Cells(i, 7).Value, b.Columns(3), 0)) And IsError(Application.Match(a.Cells(i, 4).Value, b.Columns(11), 0)) Then
a.Range("D" & i).Copy
ObjData.GetFromClipboard
strText = Replace(ObjData.GetText(), Chr(10), "")
b.Range("K" & ).Value = b.Range("K" & ).Value & " / " & strText
End If
Next i
End Sub
I face two problems, one has me stumped and the other is due to lack of knowledge:
The line after IF is supposed to check if two values (numbers) in both workbooks match, and if two other values (text) don't match. If all true, then it must copy a value from Book2 and add it to a cell in book1.
The problems are:
-The macro doesn't seem to recognise when the values match or not.
-In the last line before "End If", I don't know how to tell excel to copy the text into the cell that didn't match in the second check.
I am sorry if I am not clear enough, this is hard to explain.
I'm hoping one of the experts knows how to make this work.
Thanks in advance
You are using If Not condition 1 And condition 2, so you are saying that if it doesn't match both conditions, Then you run the code. What you want to make are Nested If Statements However, one is If and the other If Not
To copy you are missing the i After "K"&: b.Range("K" & i) = b.Range("K" & i).Value & " / " & strText
The Address of the Cells are inside the Range Function, which in your case would be:
//It is the cell of the email from the first Workbook tou are copying, where you input the column D
a.Range("D" & i).Copy
//Add to Workbook b in column K the value from Cell K#/value copied
b.Range("K" & i) = b.Range("K" & i).Value & " / " & strText
You can also make it like this: b.Range("K" & i) = b.Range("K" & i).Value & " / " & a.Range("D" & i)
This way you are matching lines, so only if the IDs are on the same rows on both Workbooks it will work. If they aren't, you will have to use Nesting Loops or .Find Function
EDIT:
If I understood it, the code below might work if you make some changes for your application, because i didn't have the data to test and columns, etc. Try to implement it.
LastRowa = a.Cells(Rows.Count, "A").End(xlUp).Row
LastRowb = b.Cells(Rows.Count, "A").End(xlUp).Row
For i = 2 To LastRowa
'Address of String to look for
LookForString = a.Worksheets(1).Cells(i, 4) '4 is the COLUMN_INDEX
'Range to look on Workbook a
With a.Worksheets(1).Range("D1:D" & LastRowa) 'choose column to look
'Function .Find String on book a
Set mail_a = .Find(LookForString, LookIn:=xlValues)
If Not mail_a Is Nothing Then
FirstAddress = mail_a.Address
Do ' Actions here
'Range to look on Workbook b
With b.Worksheets(1).Range("K1:K" & LastRowb) 'choose column to look
'Function .Find on Workbook b
Set mail_b = .Find(LookForString, LookIn:=xlValues)
If Not mail_b Is Nothing Then
FirstAddress = mail_b.Address
Do 'Actions
'Verify if two other values (text) don't match
If Not WRITE_MATCH_CONDITION_HERE Then
'No need to verify of they are equal because the .Find function used the same reference
'I will use .Cells with .Row and .Column just to show another way to do it and make it dynamic
b.Cells(mail_b.Adress.Row, mail_b.Adress.Column) = b.Cells(mail_b.Adress.Row, mail_b.Adress.Column).Value & " / " & a.Cells(mail_a.Adress.Row, mail_a.Adress.Column) 'choose columns
End If
Set mail_b = .FindNext(mail_b)
Loop While Not mail_b Is Nothing And mail_b.Address <> FirstAddress
End If
End With
Set mail_a = .FindNext(mail_a)
Loop While Not mail_a Is Nothing And mail_a.Address <> FirstAddress
End If
End With
Next i
End Sub
p.s.: The <> is missing on mail_a.Address <> FirstAddress and mail_b.Address <> FirstAddress, when i posted with
Hi I am writing a code for sum the data based on criteria. The below code working perfectly but it not return value. The code works on the excel like this (= SUMIF($B$1:$DC$1,p,B2:DD2). The reason is Criteria P Need double quotation.how to add the double quotation to P and any suggestion would be appreciated
Sub ashok()
Dim LR As Long
Dim Rg, Rg1 As Range
ActiveSheet.Range("a1").Select
LR = ActiveSheet.Range("A" & Rows.Count).End(xlUp).Row
ActiveCell.Columns("A:A").EntireColumn.Select
Selection.NumberFormat = "0"
ActiveSheet.Range("a1").Select
Set Rg = Range("b1", ActiveSheet.Range("A1").End(xlToRight))
Set Rg1 = Range("b2", ActiveSheet.Range("A2").End(xlToRight))
Range("a1").End(xlToRight).Select
With ActiveCell.Offset(1, 1).Resize(LR)
.Formula = "= SumIf(" & Rg.Address(True, True) & "," & "P" & "," & Rg1.Address(False, False) & ")"
End With
End Sub
The answer to your question is use Chr(34):
.Formula = "= SumIf(" & Rg.Address(True, True) & "," & Chr(34) & "P" & Chr(34) & "," & Rg1.Address(False, False) & ")"
However, you have way too much (unnecessary and should stay away from) use of Select, ActiveSheet, ActiveCell and Selection.
An example of how your code could look if you use fully qualified objects:
With Sheets("Sheet3") ' <-- replace with your sheet's name
LR = .Cells(.Rows.Count, "A").End(xlUp).Row
.Columns("A:A").EntireColumn.NumberFormat = "0"
Set Rg = .Range("B1", .Range("A1").End(xlToRight)) '<-- NOT SURE this make sense !
Set Rg1 = .Range("B2", .Range("A2").End(xlToRight)) '<-- NOT SURE this make sense !
' etc. etc.
End With ' closing the With
Hey guys I need help with my novice skills at VBA code writing. I would like to modify the code below to accommodate the varying ranges of data rows for my sum range and criteria range in a SUMIF statment.
Sub sumifstate ()
Set critRange = Range("K2", Selection.End(xlUp).Offset(-1, 0)).Select
Set sumRange = Range("L2", Selection.End(xlUp).Offset(-1, 0)).Select
Set critRange2 = Range("M2", Selection.End(xlUp).Offset(-1, 0)).Select
Set sumRange2 = Range("N2", Selection.End(xlUp).Offset(-1, 0)).Select
Range("K41").Select
ActiveCell.FormulaR1C1 = _
"= (SUMIF("critRange",""*DF*"","sumRange")+SUMIF("critRange2,""*DF*"","sumRange2")"
End Sub ()
I hope I was specific enough if not let me know what other information you might need. Thank you!
There is no guarantee that all four of those columns have data in the same last row. However, each SUMIF requires that all ranges have the same size. Use the same formula for each of the pairs. You are also not evaluating hte formula within VBA, merely constructing a string together. You can use the ranges' addresses as strings for this.
Sub sumifstate()
Dim lr As Long, critRange As String, sumRange As String, critRange2 As String, sumRange2 As String
lr = Cells(Rows.Count, "L").End(xlUp).Row
critRange = Range("K2:K" & lr).Address
sumRange = Range("L2:L" & lr).Address
lr = Cells(Rows.Count, "N").End(xlUp).Row
critRange2 = Range("M2:M" & lr).Address
sumRange2 = Range("N2:N" & lr).Address
Range("K41").Formula = _
"=SUMIF(" & critRange & ", ""*DF*"", " & sumRange & ")+SUMIF(" & critRange2 & ", ""*DF*"", " & sumRange2 & ")"
End Sub
The formula produced will be dynamic but in this format.
=SUMIF($K$2:$K$10, "*DF*", $L$2:$L$10)+SUMIF($M$2:$M$10, "*DF*", $N$2:$N$10)
Hi,
So where you've got R[-39] or R[-3], you want to insert a variable for your actual calculated rows?
intStartRow = GetStartRow() ' i.e. however you define it, set a variable
intEndRow = GetEndRow()
Then replace where needed:
ActiveCell.FormulaR1C1 = _
"=(SUMIF(R[" & intStartRow & "]C:R[" & intEndRow & "]C, ...
i.e. use concatenate symbol "&",
Either that or use "=Offset" formula combined with Counta: that allows you to have "growing/shrinking" ranges without having to rerun your code
So yesterday I posted my first SO question, and it went down like a ton of bricks. However I've picked myself up, dusted myself off, and hopefully this question will be more acceptable... :-)
I am trying to remove data duplicates from a list of Health Questionnaires I have to monitor, but the tricky bit I was struggling with was finding a duplicate in one column, AND then checking that the data on the same row, for the 3 adjacent columns were also duplicates. Storing the searched for 'duplicated row' was the bit that was throwing me off.
Here's some code I've cobbled together from other similarly-functioning scripts. I'm now in debug mode and keep getting errors thrown up... I don't have much experience of VBA, so i'm running out of options.
I'm currently getting type mismatch errors with the variable g, and also firstAddress. Why are these causing problems???
Can I call firstAddress.Row or am I barking up the wrong tree?
Here's the snippet:
g = .Find(Range("G" & i).Text, LookIn:=xlValues)
If Not g Is Nothing Then
firstAddress = g.Address
dupRow = firstAddress.Row
And here's the whole code below. Any help would be much appreciated!
Sub FindCpy()
Dim lw As Long
Dim i As Integer
Dim sh As Worksheet
Dim dupRow As Integer
Dim g As Integer
Dim firstAddress As Integer
'Used for the new worksheet we are pasting into
Dim objNewSheet As Worksheet
Dim rngNextAvailbleRow As Range
'Used to narrow down the logical operators for duplicates
Dim rngFirst As Range
'Set the ranges
rngFirst = Range("G" & 1, "G" & lw)
Set sh = Sheets("Completed")
lw = Range("A" & Rows.Count).End(xlUp).Row
For i = 1 To lw 'Find duplicates from the list.
If Application.CountIf(Range("A" & i & ":A" & lw), Range("A" & i).Text) = "Complete" Then
'if COMPLETE, check the rest of the sheet for any 'in progress' duplicates...
With Worksheets("Still In Progress").rngFirst
g = .Find(Range("G" & i).Text, LookIn:=xlValues)
If Not g Is Nothing Then
firstAddress = g.Address
dupRow = firstAddress.Row
If Range("H" & dupRow).Text = Range("H" & i).Text _
And Range("I" & dupRow).Text = Range("I" & i).Text _
And Range("J" & dupRow).Text = Range("J" & i).Text Then
'select the entire row
Range.EntireRow.Select
'copy the selection
Selection.Cut
'Now identify and select the new sheet to paste into
Set objNewSheet = ThisWorkbook.Worksheets("Completed")
objNewSheet.Select
'Looking at your initial question, I believe you are trying to find the next available row
Set rngNextAvailbleRow = objNewSheet.Range("A1:A" & objNewSheet.Cells(Rows.Count, "A").End(xlUp).Row)
Range("A" & rngNextAvailbleRow.Rows.Count + 1).Select
ActiveSheet.Paste
'delete the initial row
rngCell.EntireRow.Delete
Set g = .FindNext(g)
Loop While Not g Is Nothing And g.Address <> firstAddress
End If
End With
Next i
End Sub
I went through your code carefully. There were a number of problems. Some of these I think I was able to fix - there was one where I guessed what you intended to do, but for one of them I just marked it; you need to explain what you were trying to do, as you are deleting a range that you never defined...
The first problem is with the line:
If Application.CountIf(Range("A" & i & ":A" & lw), Range("A" & i).Text) = "Complete" Then
The CountIf function returns a number; you are comparing this number with the string "Complete". I don't think you can ever get past this line, so the rest of the code (whether correct or not) will not execute. Not entirely clear what you are trying to do in this line, as I'm not sure when a line will be marked "Complete" - but assuming that you are interested in executing the rest of the code if the cell in A & i has the string "Complete" in it, then you probably want to do
If Range("A" & i).Text = "Complete" Then
There were a number of If - Then, With, and Loop structures that were not properly terminated with a matching End. I have tried to remedy this - make sure I did it right. Note that using proper indentation really helps to find problems like this. The space bar is your friend...
Since the Find method returns an object, the correct way to use the function is
Set g = .Find(Range("G" & i).Text, LookIn:=xlValues)
Apart from that - use Option Explicit at the top of your code, and define variables with the most restrictive (correct) type that you can. When I did this I found the error I could not correct - with the rngCell variable that was neither declared, nor ever set... It shows just how helpful it can be. Also good for catching typos - VBA will happily let you write things like
myVar = 1
MsgBox myVra + 1
The message will be 1, not 2, because of the typo... The fact that Explicit should even be an option is one of the many inexplicable design decisions made by the VBA team.
Here is your code "with most of the errors fixed". At least like this it will compile - but you must figure out what to do with the remaining error (and I can't be sure I guessed right about what you wanted to do with the cell marked "Complete").
Comments welcome.
Option Explicit
Sub FindCpy()
Dim lw As Long
Dim i As Integer
Dim sh As Worksheet
Dim dupRow As Integer
Dim g As Range
Dim firstAddress As Range
'Used for the new worksheet we are pasting into
Dim objNewSheet As Worksheet
Dim rngNextAvailbleRow As Range
'Used to narrow down the logical operators for duplicates
Dim rngFirst As Range
'Set the ranges
rngFirst = Range("G" & 1, "G" & lw)
Set sh = Sheets("Completed")
lw = Range("A" & Rows.Count).End(xlUp).Row
For i = 1 To lw 'Find duplicates from the list.
' If Application.CountIf(Range("A" & i & ":A" & lw), Range("A" & i).Text) = "Complete" Then
If Range("A" & i).Text = "Complete" Then
'if COMPLETE, check the rest of the sheet for any 'in progress' duplicates...
With Worksheets("Still In Progress").rngFirst
Set g = .Find(Range("G" & i).Text, LookIn:=xlValues)
If Not g Is Nothing Then
firstAddress = g.Address
dupRow = firstAddress.Row
If Range("H" & dupRow).Text = Range("H" & i).Text _
And Range("I" & dupRow).Text = Range("I" & i).Text _
And Range("J" & dupRow).Text = Range("J" & i).Text Then
'select the entire row
g.EntireRow.Select
'copy the selection
Selection.Cut
'Now identify and select the new sheet to paste into
Set objNewSheet = ThisWorkbook.Worksheets("Completed")
objNewSheet.Select
'Looking at your initial question, I believe you are trying to find the next available row
Set rngNextAvailbleRow = objNewSheet.Range("A1:A" & objNewSheet.Cells(Rows.Count, "A").End(xlUp).Row)
Range("A" & rngNextAvailbleRow.Rows.Count + 1).Select
ActiveSheet.Paste
'delete the initial row
rngCell.EntireRow.Delete ' <<<<<< the variable rngCell was never defined. Cannot guess what you wanted to do here!
Do
Set g = .FindNext(g)
Loop While Not g Is Nothing And g.Address <> firstAddress
End If ' entire row matched
End If ' Not g Is Nothing
End With ' With Worksheets("Still in Progress")
End If ' CountIf = "Complete"
Next i
End Sub
Another handy trick: when you "paste in the next available row" as you are doing with Range("A" & rngNextAvailbleRow.Rows.Count + 1).Select, I usually find it handy to do something like this instead:
Dim destination As Range
Set destination = Worksheets("Sheetname").Range("A1")
And when you need to paste something:
destination.Select
ActiveSheet.Paste
Set destination = destination.Offset(1,0)
This way, destination is always pointing to the "next place where I can paste". I find it helpful and cleaner.