CODEWITHSUNDEEP
vbaexcel
walter while
walter while

Reputation: 107

Pasting count in different sheet using VBA

I have the below code that will count certain strings based on date range and update the count in a cell.

Option Explicit

Const strFormTitle = "Enter Minimum and Maximum Dates in d/m/yyyy format"  'Edit for different regional date format
Const strShtName As String = "Latency"              'Name of worksheet with ranges to be processed
Const strDateFormat As String = "d mmm yyyy"       'Edit for different regional date format
Const strCrit1 As String = "Pass, Fail, In Progress"    'Criteria for output to AE2. (Can insert or delete criteria with comma between values. OK to have spaces with the commas)
Const strCrit2 As String = "COMPATIBLE"     'Criteria for column E. (One criteria only)
Const strDateRng As String = "K:K"      'Column with Dates
Const strCrit1Col As String = "O:O"     'Column with "Pass, Fail, In Progress"
Const strCrit2Col As String = "E:E"     'Column with "COMPATIBLE"
Const strOutput1 As String = "AE2"      'The cell for output "Pass, Fail, In Progress"
Const strOutput2 As String = "AF2"      'The cell for output "Pass, Fail, In Progress" plus "COMPATIBLE"



Private Sub UserForm_Initialize()
Me.lblTitle = strFormTitle
End Sub

Private Sub cmdProcess_Click()
Dim wf As WorksheetFunction
Dim ws As Worksheet
Dim rngDates As Range       'Range of dates
Dim rngCrit1 As Range       'Range to match Criteria 1
Dim rngCrit2 As Range       'Range to match Criteria 2
Dim dteMin As Date
Dim dteMax As Date
Dim rngOutput1 As Range
Dim rngOutput2 As Range
Dim arrSplit As Variant
Dim i As Long

Set wf = Application.WorksheetFunction
Set ws = Worksheets(strShtName)
With ws
    Set rngDates = .Columns(strDateRng)
    Set rngOutput1 = .Range(strOutput1)
    Set rngOutput2 = .Range(strOutput2)
    Set rngCrit1 = .Range(strCrit1Col)
    Set rngCrit2 = .Range(strCrit2Col)
End With

dteMin = CDate(Me.txtMinDate)
dteMax = Int(CDate(Me.txtMaxDate) + 1)

If dteMin > dteMax Then
    MsgBox "Minimum date must be less than maximum date." & vbCrLf & _
            "Please re-enter a valid dates."
    Exit Sub
End If

arrSplit = Split(strCrit1, ",")

'Following loop removes any additional leading or trailing spaces (Can be in the string constant)
For i = LBound(arrSplit) To UBound(arrSplit)
    arrSplit(i) = Trim(arrSplit(i))
Next i

rngOutput1.ClearContents 'Start with blank cell
For i = LBound(arrSplit) To UBound(arrSplit)
    rngOutput1.Value = rngOutput1.Value + wf.CountIfs(rngDates, ">=" & CLng(dteMin), _
                    rngDates, "<" & CLng(dteMax), _
                    rngCrit1, arrSplit(i))
Next i

rngOutput2.ClearContents    'Start with blank cell
For i = LBound(arrSplit) To UBound(arrSplit)
    rngOutput2.Value = rngOutput2.Value + wf.CountIfs(rngDates, ">=" & CLng(dteMin), _
                    rngDates, "<" & CLng(dteMax), _
                    rngCrit1, arrSplit(i), rngCrit2, strCrit2)
Next i

End Sub


Private Sub cmdCancel_Click()
Unload Me
End Sub

Private Sub txtMinDate_AfterUpdate()
If IsDate(Me.txtMinDate) Then
    Me.txtMinDate = Format(CDate(Me.txtMinDate), strDateFormat)
Else
    MsgBox "Invalid Minimum date. Please re-enter a valid date."
End If
End Sub

Private Sub txtMaxDate_AfterUpdate()

If IsDate(Me.txtMaxDate) Then
    Me.txtMaxDate = Format(CDate(Me.txtMaxDate), strDateFormat)
Else
    MsgBox "Invalid Maximum date. Please re-enter a valid date."
End If
End Sub

Private Sub chkEntireRng_Click()
Dim wf As WorksheetFunction
Dim ws As Worksheet
Dim rngDates As Range

Set wf = WorksheetFunction
Set ws = Worksheets(strShtName)
With ws
    Set rngDates = .Columns(strDateRng)
End With
If Me.chkEntireRng = True Then
    Me.txtMinDate = Format(wf.Min(rngDates), strDateFormat)
    Me.txtMaxDate = Format(wf.Max(rngDates), strDateFormat)
    Me.txtMinDate.Enabled = False
    Me.txtMaxDate.Enabled = False
Else
    Me.txtMinDate = ""
    Me.txtMaxDate = ""
    Me.txtMinDate.Enabled = True
    Me.txtMaxDate.Enabled = True
End If

End Sub

I'm not sure how to do the below task:

  1. Currently the count is pasted in "latency" sheet, But I want to paste it in Sheet named "MySheet"
  2. How do i add multiple criteria from multiple rows? Currently its just for "COMPATIBLE" in "E", what if I need to add additional criteria for "XYZ" in "X" column?

Upvotes: 1

Views: 72

Answers (1)

Zerk
Zerk

Reputation: 1593

This code seems needlessly obfuscated with the excessive pointers, it may be good practice/learning to try refactoring it.

1: These lines are used to create the latency sheet object and the output range. I'd recommend doing the same for "Mysheet". Since you've not specified if the data is also in MySheet we need to assume it's still in the same place and not touch the existing references.

Const strShtName As String = "Latency"              'Name of worksheet with ranges to be processed
Dim ws As Worksheet
Set ws = Worksheets(strShtName)
Const strOutput1 As String = "AE2"      'The cell for output "Pass, Fail, In Progress"
Const strOutput2 As String = "AF2"      'The cell for output "Pass, Fail, In Progress" plus "COMPATIBLE"
Dim rngOutput1 As Range
Dim rngOutput2 As Range
With ws
    Set rngOutput1 = .Range(strOutput1)
    Set rngOutput2 = .Range(strOutput2)
End With

We'd add in the following to assign the new sheet object and paste range:

Dim wsMySheet As Worksheet
Set wsMySheet = Worksheets("MySheet")
Dim rngOutputMySheet as range
With wsMySheet
    Set rngOutputMySheet = .range("CELLREFHERE")
End With

The paste itself happens at the end of the sub:

rngOutput1.ClearContents 'Start with blank cell
For i = LBound(arrSplit) To UBound(arrSplit)
    rngOutput1.Value = rngOutput1.Value + wf.CountIfs(rngDates, ">=" & CLng(dteMin), _
                    rngDates, "<" & CLng(dteMax), _
                    rngCrit1, arrSplit(i))
Next i

rngOutput2.ClearContents    'Start with blank cell
For i = LBound(arrSplit) To UBound(arrSplit)
    rngOutput2.Value = rngOutput2.Value + wf.CountIfs(rngDates, ">=" & CLng(dteMin), _
                    rngDates, "<" & CLng(dteMax), _
                    rngCrit1, arrSplit(i), rngCrit2, strCrit2)
Next i

You'd replace the range reference with your new one (rngOutputMySheet)

2: Criteria are set as follows:

Const strCrit1Col As String = "O:O"     'Column with "Pass, Fail, In Progress"
Const strCrit1 As String = "Pass, Fail, In Progress" 
Dim rngCrit1 As Range       'Range to match Criteria 1
With ws
    Set rngCrit1 = .Range(strCrit1Col)
End With

and used as follows:

For i = LBound(arrSplit) To UBound(arrSplit)
    rngOutput2.Value = rngOutput2.Value + wf.CountIfs(rngDates, ">=" & CLng(dteMin), _
                    rngDates, "<" & CLng(dteMax), _
                    rngCrit1, arrSplit(i), rngCrit2, strCrit2)
Next i

To add a new criteria we'd assign the criteria & range and add them into the criteria of the countifs formula:

Dim strCrit3 as String
strCrit3 = "Criteria list here"
Dim rngCrit3 as Range
With ws
    set rngCrit3 = .Range("RANGEHERE")
End With
For i = LBound(arrSplit) To UBound(arrSplit)
    rngOutput2.Value = rngOutput2.Value + wf.CountIfs(rngDates, ">=" & CLng(dteMin), _
                    rngDates, "<" & CLng(dteMax), _
                    rngCrit1, arrSplit(i), rngCrit2, strCrit2,rngCrit3, strCrit3)
Next i

Upvotes: 1

Related Questions