PDA

View Full Version : [SOLVED] Check List, Add New Item



shades
07-01-2005, 06:55 AM
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
07-01-2005, 07:29 AM
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
07-01-2005, 07:41 AM
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
07-01-2005, 07:46 AM
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
07-01-2005, 08:37 AM
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 :giggle

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
07-01-2005, 09:19 AM
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
07-01-2005, 09:38 AM
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
07-01-2005, 09:57 AM
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
07-01-2005, 10:12 AM
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
07-01-2005, 10:17 AM
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. :clap: :clap:

shades
07-01-2005, 10:20 AM
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
07-01-2005, 10:24 AM
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
07-01-2005, 10:33 AM
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? :D

shades
07-01-2005, 11:38 AM
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
07-01-2005, 11:40 AM
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
07-01-2005, 11:41 AM
'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
07-01-2005, 11:42 AM
Interesting, I took out the Validation warning, and now the drop is the width of column D. Go figure. ;)

shades
07-01-2005, 11:44 AM
Why is it a three day weekend in Ireland?

Irish by descent, U.S. by location. :)

shades
07-01-2005, 12:04 PM
Well, I got most of the bugs ironed out. Now I sent it to a fellow worker to see if he can break it. :) :friends:

Bob Phillips
07-01-2005, 12:05 PM
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 :devil:

shades
07-01-2005, 12:26 PM
Ah, no, he is not. Can you believe that I am considered the Excel guru in my department and quite a few other departments. :eek: :yes

A quote from Slashdot is very appropriate:

"The good news is that spreadsheets let people who aren't programmers do all kinds of fancy calculations on a computer.
The bad news is that spreadsheets let people who aren't programmers do all kinds of fancy calculations on a computer. "
~Slashdot.com April 24, 2005
:whip