PDA

View Full Version : TALLY MULTIPLE COLUMNS AND OUTPUT TO NEW WORKSHEETS



Pharlap
08-06-2007, 12:35 AM
hi VBAX folks,

Hope someone would like to help

Could you review code below and suggest or make required changes

I have been working on a little vba project and have almost got there with help from others, but the final part needs to have a tally a number of columns and and produce the tally results to a new worksheets - the code that need proof reading /reviewing is below - it is not working correctly as it is not tallying correctly and at times seems to miss counting the last row - so could you review and suggest or make required changes so that it will work on the attached test file.

WHAT IS NEEDED IS;

1. Column D contains names -strings which are repeated such Fred Flintstone so for Fred and others would like to have a summary tally of how many times each worker has instances of a value appearing in columns I, J, K, L and P, R ,S, T and U.
With the output summary worksheet called "WORKER TALLY" and having the headings for each columns tallied from row 5 being headings for each column tally see attached example.

2. Then do same again for Column E - P Names so for example the P Name Peter Pan and others would like to have a summary tally of how many each worker has instances of a value appearing in columns I, J, K, L and P, R ,S, T and U. With the output summary worksheet called "P Names" and having the headings for each columns tallied from row 5 being headings for each column tally see attached example.



Sub workertally()
Dim b() As Variant
Dim NewWs As Worksheet
Dim j As Integer, i As Integer
Dim a As Range, v As Range, r As Range, c As Range
j = 1
Set a = Range("E6", Range("E" & Rows.Count).End(xlUp))
Set c = Range("E5", Cells(5, Columns.Count).End(xlToLeft))
With CreateObject("Scripting.Dictionary")
.CompareMode = vbTextCompare
For Each v In a
i = 1
If Not IsEmpty(v.Value) And Not .exists(v.Value) Then
j = j + 1: .Add v.Value, j
End If
ReDim Preserve b(1 To 10, 1 To j)
b(1, .Item(v.Value)) = v.Value
For Each r In c
Select Case r.Column
Case 6, 7, 8, 9, 13, 15, 16, 17, 18
i = i + 1: b(i, 1) = c(1, r.Column - 1)
If Not c(v.Row - 1, r.Column - 1).Value = "" Then b(i, .Item(v.Value)) = b(i, .Item(v.Value)) + 1
End Select
Next r
Next v
b(1, 1) = c(1, 1)
End With
Set NewWs = Worksheets.Add
NewWs.Name = "WORKER SUMMARY TALLY"
NewWs.Range("A1").Resize(j, 10).Value = Application.Transpose(b)
With NewWs.Range("A1", NewWs.Range("IV" & 1).End(xlToLeft))
.Font.ColorIndex = 6
.Interior.ColorIndex = 11
.Font.Name = "Arial"
.Font.Bold = True
.WrapText = True
.Rows.AutoFit
End With
NewWs.Columns(1).AutoFit
End Sub


Thanks heaps

Pharlap

Bob Phillips
08-06-2007, 02:16 AM
Don't need VBA

=SUMPRODUCT((Sheet1!$D$6:$D$200='WORKER SUMMARY TALLY'!$A2)*(Sheet1!$I$5:$L$5='WORKER SUMMARY TALLY'!B$1)*(Sheet1!$I$6:$L$200="X"))

in B2, copy to E4

=SUMPRODUCT((Sheet1!$D$6:$D$200='WORKER SUMMARY TALLY'!$A2)*(Sheet1!$P$5:$U$5='WORKER SUMMARY TALLY'!F$1)*(Sheet1!$P$6:$U$200<>""))

in F2, copy to J4

Pharlap
08-06-2007, 03:33 AM
Thanks XLD for your suggestion and time taken to respond.

However as I mentioned this is part of a bigger overall project. I am sure your formula would work fine but it is labour intensive way when wanting to add to a multiple number of workbooks that are sent to me doing this repeatly for both worker tally and Names. I could be wrong but I feel if would be a bigger time saver to have one single piece of VBA code to copy in once per workbook.

The VBA code I have provided gets close to working so if you or someone else to review it - in condiseration of the example file that would be fantastic so provide a fix for it,...or other VBA code to do the same that would be greatly appreciated.

Regards

Pharlap

Bob Phillips
08-06-2007, 05:13 AM
Sub workertally()
Dim b() As Variant
Dim NewWs As Worksheet
Dim DataWs As Worksheet
Dim j As Integer, i As Integer
Dim a As Range, v As Range, r As Range, c As Range
j = 1
Set DataWs = Worksheets("Sheet1")
Set a = DataWs.Range("E6", DataWs.Range("E" & Rows.Count).End(xlUp))
Set c = DataWs.Range("I5,J5,K5,L5,P5,R5,S5,T5,U5")

With CreateObject("Scripting.Dictionary")

.CompareMode = vbTextCompare
For Each v In a
If Not IsEmpty(v.Value) And Not .exists(v.Value) Then
j = j + 1
.Add v.Value, j
ReDim Preserve b(1 To 10, 1 To j)
b(1, .Count + 1) = v.Value

i = 1
For Each r In c
Select Case r.Column
Case 9, 10, 11, 12, 16, 18, 19, 20, 21
i = i + 1
b(i, 1) = r.Value
b(i, .Item(v.Value)) = ActiveSheet.Evaluate( _
"SUMPRODUCT(--(" & a.Columns(1).Address & "=""" & v.Value & """)," & _
"--(TRIM(" & a.Columns(r.Column - 4).Address & ")<>""""))")
End Select
Next r
End If
Next v
b(1, 1) = c(1, 1)
End With
Set NewWs = Worksheets.Add
NewWs.Name = "WORKER SUMMARY TALLY"
NewWs.Range("A1").Resize(j, 10).Value = Application.Transpose(b)
With NewWs.Range("A1", NewWs.Range("IV" & 1).End(xlToLeft))
.Font.ColorIndex = 6
.Interior.ColorIndex = 11
.Font.Name = "Arial"
.Font.Bold = True
.WrapText = True
.Rows.AutoFit
End With
NewWs.Columns(1).AutoFit
End Sub

Pharlap
08-07-2007, 02:05 AM
HI xld

Thank you so much it worked FANTASTIC for producing a summary tally for Names in Column E.

I was also wanting the same code to produce at the same time it is run a second tally worksheet for Names in Column D. I did modify the code to run just a single tally for only column D and it worked fine, but when the two piece to code to run after one another the second code run only produces all zeros in the result...I just cant get it to produce two tally summary worksheets at once. I there an easy way to modify the code to do this.

Also just a small thing I noticed is that in the summary tally output worksheet cell A1 copies the heading from cell B1 rather than having the correct column heading from the source worksheet for the respective name column...can this also be fixed...I tried several times but I just made things worse.

Again thanks for your help

My regards

Pharlap (Tony)

Bob Phillips
08-07-2007, 02:56 AM
Sub workertally()

Call TallyNames(Col:=4, shName:="WORKER SUMMARY TALLY D")
Call TallyNames(Col:=5, shName:="WORKER SUMMARY TALLY E")

End Sub

Private Sub TallyNames(ByVal Col As Long, ByVal shName As String)
Dim b() As Variant
Dim NewWs As Worksheet
Dim DataWs As Worksheet
Dim j As Integer, i As Integer
Dim a As Range, v As Range, r As Range, c As Range

j = 1
Set DataWs = Worksheets("Sheet1")
Set a = DataWs.Range(DataWs.Cells(6, Col), DataWs.Cells(DataWs.Rows.Count, Col).End(xlUp))
Set c = DataWs.Range("I5,J5,K5,L5,P5,R5,S5,T5,U5")

With CreateObject("Scripting.Dictionary")

.CompareMode = vbTextCompare
For Each v In a
If Not IsEmpty(v.Value) And Not .exists(v.Value) Then
j = j + 1
.Add v.Value, j
ReDim Preserve b(1 To 10, 1 To j)
b(1, .Count + 1) = v.Value

i = 1
For Each r In c
Select Case r.Column
Case 9, 10, 11, 12, 16, 18, 19, 20, 21
i = i + 1
b(i, 1) = r.Value
b(i, .Item(v.Value)) = ActiveSheet.Evaluate( _
"SUMPRODUCT(--(" & a.Columns(1).Address(, , , True) & "=""" & v.Value & """)," & _
"--(TRIM(" & a.Columns(r.Column - (Col - 1)).Address(, , , True) & ")<>""""))")
End Select
Next r
End If
Next v
b(1, 1) = c(1, 1)
End With
Set NewWs = Worksheets.Add
NewWs.Name = shName
NewWs.Range("A1").Resize(j, 10).Value = Application.Transpose(b)
With NewWs.Range("A1", NewWs.Range("IV" & 1).End(xlToLeft))
.Font.ColorIndex = 6
.Interior.ColorIndex = 11
.Font.Name = "Arial"
.Font.Bold = True
.WrapText = True
.Rows.AutoFit
End With
NewWs.Columns(1).AutoFit
End Sub

daniel_d_n_r
08-07-2007, 04:23 AM
why not just use a COUNTIF function at the end of each column.
Then access the value of each column with a formula.

Pharlap
08-07-2007, 04:56 AM
Hi xld

You are indeed BRILLANT your VBA for doing both tallys at once worked Great...you make VBA coding look easy...of course is requires knowledge and skill and you have it.

Could I ask for some little fine tunining at cell A1 on both output tally worksheets the column heading is a copy of B1 ...could the code be modified to have the heading of each of the source worksheet columns headings for D and E to autoinput there in A1 of the respective output worksheets.

xld...you have helped so much ...and I hate to ask for furhter help..however today while trying again to make this work I had another idea and that is as I recieve several workbooks each week with a single worksheet in them that I will run this code on and as the worksheets always have unquie names that I could merge all worksheets into one workbook - so if I could do this then I wonder would it be possible to make the same code automatically run over all worksheets in a single workbook and provide two tallys sheets for each one being for worker tally and one being for name tally for each source worksheet in the workbook. As each worksheet name would be unique than the naming convention for each in this workbook -than if it could be coded/possible for the output two worksheets tallys could have the almost the same name as their source worksheet - such as if the worksheet is called "Week26" than the output worksheet for worker tally could be "Week26 worker tally" and "Week26 names tally", and therefore a source worksheet with the name "Week27" would have output worksheets named "Week27 worker tally" and "Week27 names tally",and so on (the code would just be adding worker tally or name tally to the end of the source sheet name.....now this last part of it I tend to think may be to difficult to code...well for me it certainly is.....so as I can now have the tally sheets code working for a single worksheet in one workbook that is still a GREAT ACHIEVEMENT , but if you or anyone else reading this needs to fill (http://www.vbaexpress.com/forum/) in some time,and would like a challenge I will be over the moon if someone solves this...I will send jars of vegimite from OZ (http://www.vbaexpress.com/forum/) to anywhere on the Planet....feel free to ask me any questions that might help with understanding.

XLD Even If you dont have time to help with this last bit I still thak you so much for helping with the tally code form the single worksheet.....that is so great.....THANK HEAPS

my regards

Tony (Pharlap)

Bob Phillips
08-07-2007, 06:46 AM
You can send the vegimite to my daughter over in Queenstown/Wanaka in NZ.



Option Explicit

Sub workertally()
Dim sh As Worksheet

For Each sh In ActiveWorkbook.Worksheets
If Left$(sh.Name, 4) = "Week" Then
Call TallyNames(sh:=sh, Col:=4, shName:=sh.Name & " Worker Tally")
Call TallyNames(sh:=sh, Col:=5, shName:=sh.Name & " Name Tally")
End If
Next sh

End Sub

Private Sub TallyNames(ByVal sh As Worksheet, ByVal Col As Long, ByVal shName As String)
Dim b() As Variant
Dim NewWs As Worksheet
Dim DataWs As Worksheet
Dim j As Integer, i As Integer
Dim a As Range, v As Range, r As Range, c As Range

j = 1
Set a = sh.Range(sh.Cells(6, Col), sh.Cells(sh.Rows.Count, Col).End(xlUp))
Set c = sh.Range("I5,J5,K5,L5,P5,R5,S5,T5,U5")

With CreateObject("Scripting.Dictionary")

.CompareMode = vbTextCompare
For Each v In a
If Not IsEmpty(v.Value) And Not .exists(v.Value) Then
j = j + 1
.Add v.Value, j
ReDim Preserve b(1 To 10, 1 To j)
b(1, .Count + 1) = v.Value

i = 1
For Each r In c
Select Case r.Column
Case 9, 10, 11, 12, 16, 18, 19, 20, 21
i = i + 1
b(i, 1) = r.Value
b(i, .Item(v.Value)) = ActiveSheet.Evaluate( _
"SUMPRODUCT(--(" & a.Columns(1).Address(, , , True) & "=""" & v.Value & """)," & _
"--(TRIM(" & a.Columns(r.Column - (Col - 1)).Address(, , , True) & ")<>""""))")
End Select
Next r
End If
Next v
b(1, 1) = sh.Cells(5, Col)
End With
Set NewWs = Worksheets.Add
NewWs.Name = shName
NewWs.Range("A1").Resize(j, 10).Value = Application.Transpose(b)
With NewWs.Range("A1", NewWs.Range("IV" & 1).End(xlToLeft))
.Font.ColorIndex = 6
.Interior.ColorIndex = 11
.Font.Name = "Arial"
.Font.Bold = True
.WrapText = True
.Rows.AutoFit
End With
NewWs.Columns(1).AutoFit
End Sub

Pharlap
08-08-2007, 04:07 AM
Hi xld,

Thank you so much, the code worked perfectly you are a VBA legend coder....my aim is to achieve the knowledge level you and others on this help forum have, ...or close to it.

So how much vegimite would you like and would you like to email me a secure postal address...seriously I will send it. I was and am still so happy the code worked..it will save me so much time....this is one thing what VBA is about.... producing better information smarter and easier. I have convinced my boss to pay the course cost for me to do an advanced VBA course ...so I am looking forward to that, I know practice will help too.

Today I had a look at the output your code produced and I was thinking of making a Macro to run over all outputed summary worksheets to make a total and add an additional heading in new inserted rows above and in addtion to the existing outputed column heading....it would be exactly the same for every outputed worksheet...it would be name of our organisation and name of report and maybe an autogenerated date of the report. But then I wondered if instead of making another step with a macro if could this be added to the code again saving the need to add another step. The total in each every outputted worksheet I would like to have in the presently blank column K . The title of the total column could just be "Total" this could be a total of what is in it each row.

I have not yet finalised my thoughts on the Heading wording and font size etc, and I am embarressed to ask as you have already helped immensly ...can I ask again of you do you think this is a realatively easy thing to add to your code you have done so far what I want for final detail to the output worksheets and if so could you help with that ...if so I could post in this thread the details for the heading in next day or so with an attachment of example. I am just thinking now that perhaps an easy way of adding the heading is to have a worksheet called "Heading" with the heading and its formate already set up and then just getting the code to cody this to the top of every output worksheet ...what are your own thoughts ???

If you can't thats fine, I am still very very happy - estatic in fact and I am still most happy to send a box of vegimite to wherever you like.

My regards and much thanks

Tony (Pharlap)

Bob Phillips
08-08-2007, 04:47 AM
Tony,

It should be a simple thing to do. As you say, it would be best to have a template sheet pre-loaded, and the code could take a copy, and output to that template. When you post again, post your example workbook, with template, and with the latest version of the code.

It's OK about the vegimite, I am sure the postage costs would be more than the price, and I sure my daughter can buy it in Wanaka anyway.

BTW, I see that you are in NSW. Sydney? Damon Longworth does an Excel Conference, and they are hoping to do one in Sydney in the New Year. It is not cheap, but they are good (I know, I present at the London conference, and tried to muscle in on this one). Might be worth your checking out.

Pharlap
08-08-2007, 05:55 AM
HI xld,

Thanks for the tip about the Excel user conference that could be in Sydney next year,....Actually I grew up in Sydney but I live now in Coffs Harbour 500 km north of Sydney but getting to Sydney is not a problem and the cost of the conference I will ask my boss if he and I both can go....as he is keen to learn more about excel as well, that way work might pay the cost. But even if they don't I will just pay the cost myself as I had a look on the web site and it gave a breif on teh sorts of things covered...I have just sent an email to the conference registar for them to send me more details when they have that information available.... perhaps I might see you there xld.

It is almost the middle of the night here so I will work on my heading template tomorrow and post it with the latest version of the code tomorrow.

Thanks again for your code heap so far and the great tip about the conference.

Regards

Tony (pharlap)

Pharlap
08-09-2007, 12:06 AM
Hi xld

:bow:

I have spent some time today having a very good think about the final presentation of the summary reports which is in someways is almost as important as content.

I have attached the test workbook with multiple worksheets for testing and included in it is the most recent version of the code that works BRILLANTLY. Also included in the workbook are two additional worksheets which are the headings for the two different output worksheets, the worker heading for summary by column 4 "worker" and the PName heading for the column 5 "PName".

So the question is can code be added to the end of your code or new piece of code so at the end of creating the summary output worksheets these headings will be auto copied to their respecive worksheets. All output worksheets will the word "summary' in their worksheet name. And in worker summary worksheets will also have the word "worker" in their name, whereas PName worksheets will have "PName" in their name...if that is helpful.

Now when this heading gets copied across to output worksheets starting at cell A1 of the output worksheets and insert enough new rows to fit above the first line of summary data, needs to overlap the exsiting heading that has been generated by the summary information extraction process ,.eg overlap existing columns names and E1, E2, E3, E4 etc etc...

Then provide for the entire workbook with "summary" in the names of the output worksheets a total for column K being a total of columns B to J.

It would be good if in the part of code that creates the new worksheets if some code could be added /modified to have the print default for all new sheets set at landscape, the rows to repeat at top set to rows 1 to 5, the left and right margins set to 2, top and botton margins to 1 amd turn gridlines on. And if its possibile in the footer right hand side some text that says "Data prepared by Information Support Team" (font 12 Arial, Bold).

This would make it perfect and provide a good block of code to learn from and then be able to do similar things.

If you haven't the time to help with all of it thats OK,...as I feel I have ask for you help a lot.

I look at how much time we have wasted here at my work, by doing things manually in excel. Now that I begin learning VBA and using it and seeing what others like yourself can do with it,...I said to my boss today I feel as it until now we might have well have been using chisel and hammers on slabs of stone.

Thanks again :beerchug:

Tony (pharlap)

Bob Phillips
08-09-2007, 03:29 AM
Tony,

Here is the updated code. Give it a good test just in case I have inadvertently lost something without realising it.

As regards the print style, the whole point of using a template is not to just copy some data off of it to the new worksheet, but to copy it AS the new worksheet. That way, it inherits all of the properties of that template worksheet. So you set the template worksheets as landscape, heading rows, margins, footings, etc. and the new sheets automatically inherit that without any code - nice!.

If you want to employ me to fly over for two weeks and give you and your boss 2 weeks of intensive VBA mentoring, just say so. I am sure we can work something out <BG>.

BTW, where did this code come from originally?



Option Explicit

Sub workertally()
Dim sh As Worksheet

For Each sh In ActiveWorkbook.Worksheets
If Left$(sh.Name, 6) = "Region" Then
Call TallyNames(sh:=sh, Col:=5, shName:="PName")
Call TallyNames(sh:=sh, Col:=4, shName:="Worker")
End If
Next sh

End Sub

Private Sub TallyNames(ByVal sh As Worksheet, ByVal Col As Long, ByVal shName As String)
Dim b() As Variant
Dim NewWs As Worksheet
Dim DataWs As Worksheet
Dim j As Integer, i As Integer
Dim a As Range, v As Range, r As Range, c As Range
Dim tmp As Variant

j = 0
Set a = sh.Range(sh.Cells(6, Col), sh.Cells(sh.Rows.Count, Col).End(xlUp))
Set c = sh.Range("I5,J5,K5,L5,P5,R5,S5,T5,U5")

With CreateObject("Scripting.Dictionary")

.CompareMode = vbTextCompare
For Each v In a
If Not IsEmpty(v.Value) And Not .exists(v.Value) Then
j = j + 1
.Add v.Value, j
ReDim Preserve b(1 To 10, 1 To j)
b(1, j) = v.Value

i = 1
For Each r In c
Select Case r.Column
Case 9, 10, 11, 12, 16, 18, 19, 20, 21
i = i + 1
tmp = ActiveSheet.Evaluate( _
"SUMPRODUCT(--(" & a.Columns(1).Address(, , , True) & "=""" & v.Value & """)," & _
"--(TRIM(" & a.Columns(r.Column - (Col - 1)).Address(, , , True) & ")<>""""))")
If tmp = 0 Then tmp = ""
b(i, .Item(v.Value)) = tmp
End Select
Next r
End If
Next v
End With
Worksheets(shName & " Heading").Copy After:=Worksheets(Worksheets.Count)
Set NewWs = ActiveSheet
NewWs.Name = Left("Summary " & shName & " for " & sh.Name, 31)
NewWs.Range("A6").Resize(j, 10).Value = Application.Transpose(b)
NewWs.Range("K6").Resize(j).FormulaR1C1 = "=SUM(RC[-9]:RC[-1])"
NewWs.Columns(1).AutoFit
End Sub

Pharlap
08-09-2007, 06:02 AM
Hi xld

The code is GREAT :bow: I am very happy as to what it can do,....I have tested it on the test file several times and have spend the last hour or so looking at the changes you have made ....and trying to understand what its doing ....I find it is also good to learn by pulling things apart again, understand what each element is doing.

oh yeah and thanks for the info about the print style inhereitance...I have tried that out too and yes I can see what you were taking about,...gee I wish I know that a while ago,....I alway knew about inheritance with repsect to object oriented but just didn't know the same principal was applied here.

There is some history to the code,..which you may find interesting.

I am happy to share that with you a little about the history etc if you are OK about me sending you an email via the email contact on your profile.

I'll give you more info in the email

cheers

Tony :friends: :hi:

Bob Phillips
08-09-2007, 06:39 AM
The code is GREAT :bow: I am very happy as to what it can do,....I have tested it on the test file several times and have spend the last hour or so looking at the changes you have made ....and trying to understand what its doing ....I find it is also good to learn by pulling things apart again, understand what each element is doing.

Good. It looked okay in my testing, but you never know, and testing is definitely not my strength.


oh yeah and thanks for the info about the print style inhereitance...I have tried that out too and yes I can see what you were taking about,...gee I wish I know that a while ago,....I alway knew about inheritance with repsect to object oriented but just didn't know the same principal was applied here.

Inheritance in the OO terminology is a specific principle, but templates, be they workbooks or worksheets, are objects, so their attributes can be passed on just as easily. Really what the value of templates is all about. After, every workbook you New has some basic settings, every Word doc., all the sme principle.


There is some history to the code,..which you may find interesting.

I am happy to share that with you a little about the history etc if you are OK about me sending you an email via the email contact on your profile.

I would be interested, but don't mail my PM, my mailbox is full up due to keep receiving PMs from people here asking me directly rather than posting, so it won't get through I will PM you with an alternative email.

Pharlap
08-10-2007, 02:37 AM
Hi xld

I have just replied to your email

cheers
Pharlap