Check List, Add New Item

[shades]

I have a project scorecard, which I have 95% figured out. However, one piece of code is eluding me. The scorecard [B1_Scorecard] (completed by executive level) involves five steps

1. In Cell H2 selecting from a Dropdown (TV, Print, etc.)

2. In Cell H3 typing in Project Name.

3. In Cells D6: D11, drop downs for Yes/No (begins with blank). These have to be completed, so first part of code is error checking to make sure each of these cells has been completed. If not, then a message appears that they need to make a selection in the specific cell.

4. In Cells D15: D19 , drop downs for Exempt/Yes/No (begins with blank). These have to be completed, so first part of code is error checking to make sure each of these cells has been completed. If not, then a message appears that they need to make a selection in the specific cell.

5. The score is determined by formulas for D6: D11 and D15: D19. Works great. The idea is once they have completed the evaluation of the Project under a certain category (i.e. TV), then they will click on a button and the code will do its job.

The code works for # 3 and 4 (first part of the code). Also, the last part of the code works. It takes the score (Cell D22 on B1_Scorecard) and looks for the proper column on C1_Summary, based on the value in Cell H2 on B1_Scorecard, and places it at the bottom of that column. And the Cells D6: D11 and D15: D19 are reset at the end, ready for the next project.

The problem is that the Project name will be the same for several of the areas, i.e. Project A will have entries for TV, Print, Radio, but not for Online. And Project B might have entires for TV, Online, Direct, but not Print or Radio. So, I have to check whether the Project name (in column C on C1_Summary) already has the current one under evaluation. If it does, then it should not paste the name of the project, but it should move to the correct column to record the score. However, if the the name does not yet exist, then it should paste the Project name into column C. My problem is that the code seems to keep adding the Project name, even if it is already there.

Sub Macro1()
Dim myCell As Range, myRng As Range, checkRng As Range
Dim myStr As String
Dim FinalRow As Long
Dim k As Integer, m As Integer, p As Integer
Dim RowCt As Long
FinalRow = Sheets("C1_Summary").Range("C65356").End(xlUp).Row
Set checkRng = Range("D6: D11")
For m = 6 To 11
If Cells(m, 4).Value = "" Then
MsgBox "Select ""Yes or No"" for cell D" & m
Exit Sub
End If
Next m
For p = 15 To 19
If Cells(p, 4).Value = "" Then
MsgBox "Select ""Yes or No"" for cell D" & p
Exit Sub
End If
Next p
Set myRng = Sheets("C1_Summary").Range("C4:C" & FinalRow)
' ---------------------------------
' Here is the problem area 
For Each myCell In myRng
If myCell.Value <> Sheets("B1_Scorecard").Range("H3") Then
Sheets("C1_Summary").Cells(FinalRow + 1, 3).Value = Sheets("B1_Scorecard").Range("H3")
End If
Next myCell
' ---------------------------------
myStr = Sheets("B1_Scorecard").Range("H2").Value
Worksheets("C1_Summary").Activate
Select Case myStr
Case Is = "TV"
Sheets("B1_Scorecard").Range("D22").Copy
Sheets("C1_Summary").Cells(FinalRow + 1, 4).PasteSpecial _
Paste:=xlPasteValues
Case Is = "Print"
Sheets("B1_Scorecard").Range("D22").Copy
Sheets("C1_Summary").Cells(FinalRow + 1, 5).PasteSpecial _
Paste:=xlPasteValues
Case Is = "Magazine"
Sheets("B1_Scorecard").Range("D22").Copy
Sheets("C1_Summary").Cells(FinalRow + 1, 6).PasteSpecial _
Paste:=xlPasteValues
Case Is = "Radio"
Sheets("B1_Scorecard").Range("D22").Copy
Sheets("C1_Summary").Cells(FinalRow + 1, 7).PasteSpecial _
Paste:=xlPasteValues
Case Is = "Online"
Sheets("B1_Scorecard").Range("D22").Copy
Sheets("C1_Summary").Cells(FinalRow + 1, 8).PasteSpecial _
Paste:=xlPasteValues
Case Is = "Outdoor"
Sheets("B1_Scorecard").Range("D22").Copy
Sheets("C1_Summary").Cells(FinalRow + 1, 9).PasteSpecial _
Paste:=xlPasteValues
Case Is = "Collateral"
Sheets("B1_Scorecard").Range("D22").Copy
Sheets("C1_Summary").Cells(FinalRow + 1, 10).PasteSpecial _
Paste:=xlPasteValues
Case Is = "POP"
Sheets("B1_Scorecard").Range("D22").Copy
Sheets("C1_Summary").Cells(FinalRow + 1, 11).PasteSpecial _
Paste:=xlPasteValues
Case Is = "Direct"
Sheets("B1_Scorecard").Range("D22").Copy
Sheets("C1_Summary").Cells(FinalRow + 1, 12).PasteSpecial _
Paste:=xlPasteValues
End Select
Application.CutCopyMode = False
Sheets("B1_Scorecard").Select
Range("H2").Value = ""
Range("D6: D11").Value = ""
Range("D15: D19").Value = ""
End Sub

Note: because of the smilies, there is a space added between : and D in several lines.

Any help on this part will be greatly appreciated.

[Bob Phillips]

I have a project scorecard, which I have 95% figured out. However, one piece of code is eluding me. The scorecard [B1_Scorecard] (completed by executive level) involves five steps

1. In Cell H2 selecting from a Dropdown (TV, Print, etc.)

2. In Cell H3 typing in Project Name.

3. In Cells D6: D11, drop downs for Yes/No (begins with blank). These have to be completed, so first part of code is error checking to make sure each of these cells has been completed. If not, then a message appears that they need to make a selection in the specific cell.

4. In Cells D15: D19 , drop downs for Exempt/Yes/No (begins with blank). These have to be completed, so first part of code is error checking to make sure each of these cells has been completed. If not, then a message appears that they need to make a selection in the specific cell.

5. The score is determined by formulas for D6: D11 and D15: D19. Works great. The idea is once they have completed the evaluation of the Project under a certain category (i.e. TV), then they will click on a button and the code will do its job.

The code works for # 3 and 4 (first part of the code). Also, the last part of the code works. It takes the score (Cell D22 on B1_Scorecard) and looks for the proper column on C1_Summary, based on the value in Cell H2 on B1_Scorecard, and places it at the bottom of that column. And the Cells D6: D11 and D15: D19 are reset at the end, ready for the next project.

The problem is that the Project name will be the same for several of the areas, i.e. Project A will have entries for TV, Print, Radio, but not for Online. And Project B might have entires for TV, Online, Direct, but not Print or Radio. So, I have to check whether the Project name (in column C on C1_Summary) already has the current one under evaluation. If it does, then it should not paste the name of the project, but it should move to the correct column to record the score. However, if the the name does not yet exist, then it should paste the Project name into column C. My problem is that the code seems to keep adding the Project name, even if it is already there.

Struggling to follow it precisely but should this line

Set myRng = Range("C4:C" & FinalRow)

be

Set myRng = Sheets("C1_Summary").Range("C4:C" & FinalRow)

[shades]

Yes. I had it in there. Then was trying something else, and had entered code that made the sheet active (and removed the sheet reference), so forgot to include the sheet reference after I removed the other code. Thanks.

I cleaned up the workbook and attached a sample. Perhaps that will help.

EDIT: I added two lines to exit sub after checking cells D6: D11 and D15: D19.

[shades]

BTW, I had considered using a UserForm, and even began the process. But I haven't perfected that area of VBA (only dabbled), so thought this approach would be easier for someone else to troubleshoot.

[Bob Phillips]

Phew, that took more than I bargained for.

the problem lay in this code

For Each myCell In myRng
        If myCell.Value <> Sheets("B1_Scorecard").Range("H3") Then
            Sheets("C1_Summary").Cells(FinalRow + 1, 3).Value = Sheets("B1_Scorecard").Range("H3")
        End If
    Next myCell

as unless the very first item is the same project, it will create a new one (the <> being true in this case). And then it needs the second and so on to be the same (never likely). I changed that to a match

Dim iMatchRow As Long
        On Error Resume Next
            iMatchRow = Application.Match(projectRng.Value, myRng, 0)
        On Error GoTo 0
        If iMatchRow = 0 Then
               Sheets("C1_Summary").Cells(FinalRow + 1, 3).Value = projectRng.Value
            iMatchRow = myRng(myRng.Count).Row - myRng.Row + 1
        End If

I also changed the colun identification from the long Select Case to a single match, simpler and more extensible.

I hope that you don't mind, but I made a number of otehr changes as I was struggling making changes to suit, so I changed the lot to a more flexiible set (IMO). Hope it still works on a Mac

Here is the final code

Sub Macro1()
    Dim myCell As Range, myRng As Range, checkRng As Range, check2Rng As Range
    Dim campaignRng As Range, promoRng As Range, projectRng As Range, scoreRng As Range
    Dim myStr As String
    Dim FinalRow As Long
    Dim k As Integer, m As Integer, p As Integer
    Dim RowCt As Long
    Dim cell As Range
Const RANGE_CHECK As String = "D6:D11"      'B1_Scorecard
    Const RANGE_CHECK2 As String = "D15:D19"    'B1_Scorecard
    Const RANGE_CAMPAIGN As String = "H2"       'B1_Scorecard
    Const RANGE_PROJECT As String = "H3"        'B1_Scorecard
    Const RANGE_SCORE As String = "D22"         'B1_Scorecard
    Const RANGE_PROMO As String = "D4:L4"       'C1_Summary
FinalRow = Worksheets("C1_Summary").Cells(Rows.Count, "C").End(xlUp).Row
Set promoRng = Worksheets("C1_Summary").Range(RANGE_PROMO)
With Worksheets("B1_Scorecard")
        Set campaignRng = .Range(RANGE_CAMPAIGN)
        Set projectRng = .Range(RANGE_PROJECT)
        Set checkRng = .Range(RANGE_CHECK)
        Set check2Rng = .Range(RANGE_CHECK2)
        Set scoreRng = .Range(RANGE_SCORE)
For Each cell In checkRng
            If cell.Value = "" Then
                MsgBox "Select ""Yes or No"" for cell " & cell.Address(False, False)
            End If
        Next cell
        For Each cell In check2Rng
            If cell.Value = "" Then
                MsgBox "Select ""Yes, No or Exempt"" for cell " & cell.Address(False, False)
            End If
        Next cell
Set myRng = Worksheets("C1_Summary").Range("C4:C" & FinalRow)
Dim iMatchRow As Long
        On Error Resume Next
            iMatchRow = Application.Match(projectRng.Value, myRng, 0)
        On Error GoTo 0
        If iMatchRow = 0 Then
            Sheets("C1_Summary").Cells(FinalRow + 1, 3).Value = projectRng.Value
            iMatchRow = myRng(myRng.Count).Row - myRng.Row + 1
        End If
Dim iMatchCol As Long
On Error Resume Next
            iMatchCol = Application.Match(campaignRng.Value, promoRng, 0)
        On Error GoTo 0
        If iMatchCol > 0 Then
            scoreRng.Copy
            promoRng.Cells(iMatchRow, iMatchCol).PasteSpecial Paste:=xlPasteValues
campaignRng.Value = ""
            checkRng.Value = ""
            check2Rng.Value = ""
Else
            MsgBox campaignRng.Value & " not matched"
        End If
    End With
Application.CutCopyMode = False
End Sub

PS watch the smileys

[shades]

Thanks!! Yes, it is a little more than what I originally bargained for too!

Hope it still works on a Mac

No, this is for Excel 2003 (Win 2k).

Everything works except one slight problem. If the first mention of the new program/campaign, then it pastes one row above where the campaign is listed. After it is listed, then it works okay. I tried adding 1 to this line:

promoRng.Cells(iMatchRow + 1, iMatchCol).PasteSpecial Paste:=xlPasteValues

Which works great for the first item for Program C. But for the next ones, it is placed one row below. Looks like I will have to have two separate cases (checking to see if the program is listed; if it is, then use your original code, if it is not, use the above code).

Appreciate the work!!

[Bob Phillips]

Everything works except one slight problem. If the first mention of the new program/campaign, then it pastes one row above where the campaign is listed. After it is listed, then it works okay.

Shades,

Change this line

iMatchRow = myRng(myRng.Count).Row - myRng.Row + 1

to

iMatchRow = myRng(myRng.Count).Row - myRng.Row + 2

BTW, I found that I could put invalid values in the dropdowns. I could add Yes with a traiking space, and ditto No, which caused no score but not a code validation error (as it only checks for <> "").

[shades]

Thanks. I will have to look at the invalid entries in the cells.

I have been adjusting and playing (changed a couple of the names, based on changing requirements: projectRng >>>> mediaRange (then switched references to the two cells for Campaign and Media). Works fine.

I also added two checks to make sure H2 and H3 are filled in.

[Bob Phillips]

I have been adjusting and playing (changed a couple of the names, based on changing requirements: projectRng >>>> mediaRange (then switched references to the two cells for Campaign and Media). Works fine.

Proving the flexibility I added

[shades]

Okay, here is the revised code, and everything seems to work fine now. But I will idiot-proof it several times before letting any executive try it.

Option Explicit
Sub RecordScore()
    Dim Cell As Range, myRng As Range, checkRng As Range, check2Rng As Range
    Dim campaignRng As Range, promoRng As Range, mediaRng As Range, scoreRng As Range
    Dim FinalRow As Long
Const RANGE_CHECK As String = "D6:D11" 'B1_Scorecard
    Const RANGE_CHECK2 As String = "D15:D19" 'B1_Scorecard
    Const RANGE_CAMPAIGN As String = "H3" 'B1_Scorecard
    Const RANGE_MEDIA As String = "H2" 'B1_Scorecard
    Const RANGE_SCORE As String = "D22" 'B1_Scorecard
    Const RANGE_PROMO As String = "D4:L4" 'C1_Summary
FinalRow = Worksheets("C1_Summary").Cells(Rows.Count, "C").End(xlUp).Row
Set promoRng = Worksheets("C1_Summary").Range(RANGE_PROMO)
With Worksheets("B1_Scorecard")
        Set campaignRng = .Range(RANGE_CAMPAIGN)
        Set mediaRng = .Range(RANGE_MEDIA)
        Set checkRng = .Range(RANGE_CHECK)
        Set check2Rng = .Range(RANGE_CHECK2)
        Set scoreRng = .Range(RANGE_SCORE)
 ' check two cells Media and Campaign
        If Range(RANGE_MEDIA).Value = "" Then
            MsgBox "Select Media type in Cell H2"
            Exit Sub
        End If
If Range(RANGE_CAMPAIGN).Value = "" Then
            MsgBox "Select Campaign in Cell H3"
            Exit Sub
        End If
 ' checks D6:D11 to be sure each cell is filled in
        For Each Cell In checkRng
            Select Case Cell.Value
                Case "Yes"
                Case "No"
                Case Else
                    MsgBox "Select ""Yes or No"" for cell " & Cell.Address(False, False)
                    Exit Sub
            End Select
        Next Cell
 ' checks D15:D19 to be sure each cell is filled in
         For Each Cell In check2Rng
            Select Case Cell.Value
                Case "Yes"
                Case "No"
                Case "Exempt"
                Case Else
                    MsgBox "Select ""Yes or No"" for cell " & Cell.Address(False, False)
                    Exit Sub
            End Select
        Next Cell
        Set myRng = Worksheets("C1_Summary").Range("C4:C" & FinalRow)
Dim iMatchRow As Long
        On Error Resume Next
        iMatchRow = Application.Match(campaignRng.Value, myRng, 0)
        On Error GoTo 0
        If iMatchRow = 0 Then
            Sheets("C1_Summary").Cells(FinalRow + 1, 3).Value = campaignRng.Value
            iMatchRow = myRng(myRng.Count).Row - myRng.Row + 2
        End If
Dim iMatchCol As Long
On Error Resume Next
        iMatchCol = Application.Match(mediaRng.Value, promoRng, 0)
        On Error GoTo 0
        If iMatchCol > 0 Then
            scoreRng.Copy
            promoRng.Cells(iMatchRow, iMatchCol).PasteSpecial Paste:=xlPasteValues
mediaRng.Value = ""
            checkRng.Value = ""
            check2Rng.Value = ""
Else
            MsgBox campaignRng.Value & " not matched"
        End If
    End With
Application.CutCopyMode = False
End Sub

I have assigned it to a button the worksheet, so that all that is needed is to fill in cells and click the button ("Record Score"). The worksheet will be protected as well to make it as tamper-proof as possible.

I had worked on it about 2 weeks ago, then got overwhelmed with "urgent" projects. So just got back to working on the code today.

Really appreciate the help.

[shades]

I do have a few more trials to see if I can break the code/spreadsheet. But essentially I am marking this as SOLVED.

[Bob Phillips]

I do have a few more trials to see if I can break the code/spreadsheet. But essentially I am marking this as SOLVED.

A couple of small changes suggested, as there was still some hard-coding in there.

I also see you removed the unused variables, good on you.

Sub RecordScore()
    Dim Cell As Range, myRng As Range, checkRng As Range, check2Rng As Range
    Dim campaignRng As Range, promoRng As Range, mediaRng As Range, scoreRng As Range
    Dim FinalRow As Long
Const RANGE_CHECK As String = "D6:D11" 'B1_Scorecard
    Const RANGE_CHECK2 As String = "D15:D19" 'B1_Scorecard
    Const RANGE_CAMPAIGN As String = "H3" 'B1_Scorecard
    Const RANGE_MEDIA As String = "H2" 'B1_Scorecard
    Const RANGE_SCORE As String = "D22" 'B1_Scorecard
    Const RANGE_PROMO As String = "D4:L4" 'C1_Summary
FinalRow = Worksheets("C1_Summary").Cells(Rows.Count, "C").End(xlUp).Row
Set promoRng = Worksheets("C1_Summary").Range(RANGE_PROMO)
With Worksheets("B1_Scorecard")
        Set campaignRng = .Range(RANGE_CAMPAIGN)
        Set mediaRng = .Range(RANGE_MEDIA)
        Set checkRng = .Range(RANGE_CHECK)
        Set check2Rng = .Range(RANGE_CHECK2)
        Set scoreRng = .Range(RANGE_SCORE)
         ' check two cells Media and Campaign
        If Range(RANGE_MEDIA).Value = "" Then
            MsgBox "Select Media type in Cell " & Range(RANGE_MEDIA).Address(False, False)
            Exit Sub
        End If
If Range(RANGE_CAMPAIGN).Value = "" Then
            MsgBox "Select Campaign in Cell " & Range(RANGE_CAMPAIGN).Address(False, False)
            Exit Sub
        End If
         ' checks RANGE_CHECK to be sure each cell is filled in
        For Each Cell In checkRng
            Select Case Cell.Value
            Case "Yes", "No"
            Case Else
                MsgBox "Select ""Yes or No"" for cell " & Cell.Address(False, False)
                Exit Sub
            End Select
        Next Cell
         ' checks RANGE_CHECK2 to be sure each cell is filled in
        For Each Cell In check2Rng
            Select Case Cell.Value
            Case "Yes", "No", "Exempt"
            Case Else
                MsgBox "Select ""Yes or No"" for cell " & Cell.Address(False, False)
                Exit Sub
            End Select
        Next Cell
Set myRng = Worksheets("C1_Summary").Range("C4:C" & FinalRow)
Dim iMatchRow As Long
        On Error Resume Next
        iMatchRow = Application.Match(campaignRng.Value, myRng, 0)
        On Error GoTo 0
        If iMatchRow = 0 Then
            Worksheets("C1_Summary").Cells(FinalRow + 1, 3).Value = campaignRng.Value
            iMatchRow = myRng(myRng.Count).Row - myRng.Row + 2
        End If
Dim iMatchCol As Long
On Error Resume Next
        iMatchCol = Application.Match(mediaRng.Value, promoRng, 0)
        On Error GoTo 0
        If iMatchCol > 0 Then
            scoreRng.Copy
            promoRng.Cells(iMatchRow, iMatchCol).PasteSpecial Paste:=xlPasteValues
            mediaRng.Value = ""
            checkRng.Value = ""
            check2Rng.Value = ""
        Else
            MsgBox campaignRng.Value & " not matched"
        End If
    End With
Application.CutCopyMode = False
End Sub

[shades]

Ah, thanks. I have learned a lot just from poking around what you have done. Two birds: finished project and learned some more about vba.

'tis a good day. And it is pay-day. And it is Friday. And it is the beginning of a three-day weekend!

What more could I want?

[shades]

One issue still not resolved. The Data validation boxes (D6: D11, D15: D19) drop as wide as columns A-D combined (see attachment in earlier posts), rather than just the width of column D. Is there anyway to control/change that?

[Bob Phillips]

One issue still not resolved. The Data validation boxes (D6: D11, D15: D19) drop as wide as columns A-D combined (see attachment in earlier posts), rather than just the width of column D. Is there anyway to control/change that?

Yeah, get rid of that horrible merged cell in the header and use Formart?Cell>Alignment and use Center Acroos Selection in the Horizintal alignmnet box.

[Bob Phillips]

'tis a good day. And it is pay-day. And it is Friday. And it is the beginning of a three-day weekend!

Why is it a three day weekend in Ireland?

[shades]

Interesting, I took out the Validation warning, and now the drop is the width of column D. Go figure.

[shades]

Why is it a three day weekend in Ireland?

Irish by descent, U.S. by location.

[shades]

Well, I got most of the bugs ironed out. Now I sent it to a fellow worker to see if he can break it.

[Bob Phillips]

Well, I got most of the bugs ironed out. Now I sent it to a fellow worker to see if he can break it.

If he is a user, he will