• Status: Solved
  • Priority: Medium
  • Security: Public
  • Views: 329
  • Last Modified:

.VBS Script needed for use within Excel for automation

Hi there
I am in need of a script that can accomplish the following on a Excel Spread sheet:

1 - Open C:\myfile\myexcel.xls
2 - Create a new Worksheet called STATS
3 - Count column D for all unique items & place count at the 1st row of column D on
worksheet STATS (These are business source codes (non numeric))

The tricky part:
4 - Sum the total in column R (called sheet1) for each unque source code from the 1st worksheet, #3 was unique but for every unque source code the script found in column D I would like to know the total amount of revenue posted in column R associated to each source code (counting blanks, labeling as None) and place the total into the STATS worksheet:

Example:
COLUMNA    COLUMN B               COLUMNC          COLUMND
SOURCE1     $TOTAL_REVENUE  TOTALCOUNT   TOTALUNIQUE
SOURCE2     $TOTAL_REVENUE  TOTALCOUNT
SOURCE3     $TOTAL_REVENUE  TOTALCOUNT
None             $TOTAL_REVENUE  TOTALCOUNT

5 - Save to the same file as above
6 - close excel

Thanks as always for your help, please note I need this to be a .VBS script not VBA, this will be used within a DOS Batch file for automation purposes.

Thank you again!
0
smyers051972
Asked:
smyers051972
  • 12
  • 6
  • 2
1 Solution
 
DaveCommented:
Yep, this is soundling a little tricky :)
Do you have sample file (before and final) to help guide us?
Cheers
Dave
0
 
wobbledCommented:
Here to start with... Open workbook and add sheet

    Dim objExcel As Object
    Dim objWorkBook As Object
    Dim objWorkSheet As Object
    Set objExcel = CreateObject("EXCEL.APPLICATION")
    Set objWorkBook = objExcel.Workbooks.Open("C:\myfile\myexcel.xls")
   
    Set objWorkSheet = objWorkBook.Worksheets.Add(, "STATS")
   
    'now we can manipulate it just add code here
   
   
    'final part to close it
    objWorkBook.SaveAs ("C:\myfile\myexcel.xls")
    objWorkBook.Close True
    Set objWorkBook = Nothing
    Set objExcel = Nothing
0
 
wobbledCommented:
Just checking you say "3 - Count column D for all unique items & place count at the 1st row of column D on
worksheet STATS (These are business source codes (non numeric))"

Which worksheet is column D on?
0
Ultimate Tool Kit for Technology Solution Provider

Broken down into practical pointers and step-by-step instructions, the IT Service Excellence Tool Kit delivers expert advice for technology solution providers. Get your free copy now.

 
smyers051972Author Commented:
I was just typing that as my example, there are probably a few hundred or so records in some of those cases.

Lets say there are 200 (count) SOURCE1, 150 (count) SOURCE2 and 101 (count) SOURCE3 records on sheet1, I would like the above to reflect total revenue for each of those sources in the STATS worksheet.

Then the final Column D on sheet1 would be the total count of unique source codes from the first worksheet, so it should only count each source code one time for the unique count.

Let me know if that helps, if I still need to upload a sample spread sheet I will copy part of the existing XLS file I have when I get into the office (about 1 1/2 hours from now).

Thanks!
0
 
DaveCommented:
Pls upload the sheet. It will help with the  problem part in (3) and (4)
Cheers
Dave
0
 
smyers051972Author Commented:
Will do dave, headed to work in a few minutes here!
0
 
DaveCommented:
Thx.  I'll be turning in for the night shortly, so I will have a look at this tomorrow if no-one else has picked it up in the interim :)
0
 
smyers051972Author Commented:
Here you go as promised. I had to remove the names etc to protect the innocent :)

I bolded the two columns of interest.

sample-players.xls
0
 
smyers051972Author Commented:
Let me re-upload, I forgot the mock up of sheet1, now its included.

Thanks!

sample-players.xls
0
 
smyers051972Author Commented:
The more I think of it though, I want to put the total count of uniques on column D2 because I need a header for D1 to say "Uniques" on it instead of just a number.

Thanks!
0
 
DaveCommented:
Hope this helps  :)
Cheers
Dave

    Dim objExcel, objWorkbook, objWorksheet
    Dim objWorksheet2, objRange , objRange2
    Dim rngAddy, rngAddy2
    Dim Headers
    Headers = Array("Source","Revenue","Count","Unique")
    Set objExcel = CreateObject("Excel.Application")
    Set objWorkbook = objExcel.Workbooks.Open("C:\myfile\myexcel.xls")
    On Error Resume Next
    objExcel.DisplayAlerts = False
    objWorkbook.Sheets("Stats").Delete
    On Error GoTo 0
    Set objWorksheet = objWorkbook.Worksheets(1)
    Set objRange = objExcel.Range(objWorksheet.Range("o1"), objWorksheet.Range("o1").End(-4121))
    Set objWorksheet2 = objWorkbook.Worksheets.Add
    objWorksheet2.Name = "Stats"
    With objRange
        .AdvancedFilter 1, , , True
        .Copy objWorksheet2.Range("A1")
    End With
    objWorksheet.AutoFilterMode = False
    On Error Resume Next
    Set objRange2 = objWorksheet2.Columns("A").SpecialCells(xlBlanks)
    objRange2.EntireRow.Delete
    On Error GoTo 0
    Set objRange2 = objExcel.Range(objWorksheet2.Range("A2"), objWorksheet2.Range("A2").End(-4121))
    rngAddy = "'" & objRange.Parent.Name & "'!" & objRange.Address(, , -4150)
    rngAddy2 = "'" & objRange.Parent.Name & "'!" & objRange.Offset(0, 3).Address(,,-4150)
    objRange2.Offset(0, 2).FormulaR1C1 = "=COUNTIF(" & rngAddy & ",'Stats'!RC1)"
    objRange2.Offset(0, 1).FormulaR1C1 = "=SUMIF(" & rngAddy & ",'Stats'!RC1," & rngAddy2 & ")"
    objWorksheet2.range("A1:D1") = Headers
    objWorksheet2.range("D2") = objWorksheet2.usedrange.rows.count -1
    objWorkbook.Save
    objWorkbook.Close False
    objExcel.DisplayAlerts = True
    objExcel.Quit

Open in new window

0
 
smyers051972Author Commented:
Will test at work, if it works, you ready for part 2 of this request? =)
Ill open a new question for it of course it has to do with building a pie chart based on the above lol
0
 
smyers051972Author Commented:
Ok only a couple issues with this script, it hides most of the report on the main worksheet I suspect after, I understand this may be required to get the uniques however after its done, how do we unhide everything from the original worksheet?

The only other issue I saw was it left auto filter off, this should be turned back on for the parent work sheet only.

Thanks!
0
 
smyers051972Author Commented:
I added the one line after .Copy objWorksheet2.Range("A1") to unhide (figured that out) but I cant get autofilter to turn back on. Here is the changed code.

	Dim objExcel, objWorkbook, objWorksheet
    Dim objWorksheet2, objRange , objRange2
    Dim rngAddy, rngAddy2
    Dim Headers
    Headers = Array("Source","Revenue","Count","Unique")
    Set objExcel = CreateObject("Excel.Application")
    Set objWorkbook = objExcel.Workbooks.Open("D:\newplayers.xls")
    On Error Resume Next
    objExcel.DisplayAlerts = False
    objWorkbook.Sheets("Stats").Delete
    On Error GoTo 0
    Set objWorksheet = objWorkbook.Worksheets(1)
    Set objRange = objExcel.Range(objWorksheet.Range("o1"), objWorksheet.Range("o1").End(-4121))
    Set objWorksheet2 = objWorkbook.Worksheets.Add
    objWorksheet2.Name = "Stats"
    With objRange
        .AdvancedFilter 1, , , True
        .Copy objWorksheet2.Range("A1")
	    .AdvancedFilter 1, , , False
    End With
    objWorksheet.AutoFilterMode = False
    On Error Resume Next
    Set objRange2 = objWorksheet2.Columns("A").SpecialCells(xlBlanks)
    objRange2.EntireRow.Delete
    On Error GoTo 0
    Set objRange2 = objExcel.Range(objWorksheet2.Range("A2"), objWorksheet2.Range("A2").End(-4121))
    rngAddy = "'" & objRange.Parent.Name & "'!" & objRange.Address(, , -4150)
    rngAddy2 = "'" & objRange.Parent.Name & "'!" & objRange.Offset(0, 3).Address(,,-4150)
    objRange2.Offset(0, 2).FormulaR1C1 = "=COUNTIF(" & rngAddy & ",'Stats'!RC1)"
    objRange2.Offset(0, 1).FormulaR1C1 = "=SUMIF(" & rngAddy & ",'Stats'!RC1," & rngAddy2 & ")"
    objWorksheet2.range("A1:D1") = Headers
    objWorksheet2.range("D2") = objWorksheet2.usedrange.rows.count -1
    objWorkbook.Save
    objWorkbook.Close False
    objExcel.DisplayAlerts = True
    objExcel.Quit

Open in new window

0
 
smyers051972Author Commented:
I was working with it some more and made some changes I would like to keep so when you see this, and can help me fix auto filter and auto fit doesnt seem to work either, I commented it out again but here is the updated code.

Thanks again!!!

	Dim objExcel, objWorkbook, objWorksheet
    Dim objWorksheet2, objRange , objRange2
    Dim rngAddy, rngAddy2
    Dim Headers
    Headers = Array("Manufacturer","CIPUPD Revenue","Machine Count","Unique Mfrs","     ","Avg Per Ship","Avg Per Machine")
    Set objExcel = CreateObject("Excel.Application")
    Set objWorkbook = objExcel.Workbooks.Open("D:\Dailyslotreports.xls")
    On Error Resume Next
    objExcel.DisplayAlerts = False
    objWorkbook.Sheets("Stats").Delete
    On Error GoTo 0
    Set objWorksheet = objWorkbook.Worksheets(1)
    Set objRange = objExcel.Range(objWorksheet.Range("E1"), objWorksheet.Range("E1").End(-4121))
    Set objWorksheet2 = objWorkbook.Worksheets.Add
    objWorksheet2.Name = "Stats"
    With objRange
        .AdvancedFilter 1, , , True
        .Copy objWorksheet2.Range("A1")
	    .AdvancedFilter 1, , , False
        '.Columns.AutoFit 
   End With
    objWorksheet.AutoFilterMode = False
    On Error Resume Next
    Set objRange2 = objWorksheet2.Columns("A").SpecialCells(xlBlanks)
    objRange2.EntireRow.Delete
    On Error GoTo 0
    Set objRange2 = objExcel.Range(objWorksheet2.Range("A2"), objWorksheet2.Range("A2").End(-4121))
    rngAddy = "'" & objRange.Parent.Name & "'!" & objRange.Address(, , -4150)
    rngAddy2 = "'" & objRange.Parent.Name & "'!" & objRange.Offset(0, 9).Address(,,-4150)
    objRange2.Offset(0, 2).FormulaR1C1 = "=COUNTIF(" & rngAddy & ",'Stats'!RC1)"
    objRange2.Offset(0, 1).FormulaR1C1 = "=SUMIF(" & rngAddy & ",'Stats'!RC1," & rngAddy2 & ")"
    objRange2.Offset(0, 5).FormulaR1C1 = "=SUMIF(" & rngAddy & ",'Stats'!RC1," & rngAddy2 & ")/9"
    objRange2.Offset(0, 6).FormulaR1C1 = "=SUMIF(" & rngAddy & ",'Stats'!RC1," & rngAddy2 & ")/COUNTIF(" & rngAddy & ",'Stats'!RC1)"
	objWorksheet2.range("A1:G1") = Headers
    objWorksheet2.range("D2") = objWorksheet2.usedrange.rows.count -1
    objWorkbook.Save
    objWorkbook.Close False
    objExcel.DisplayAlerts = True
    objExcel.Quit

Open in new window

0
 
smyers051972Author Commented:
I did change the columns to see if I could figure it out dont worry about that I will change them back as needed, this is just me trying to learn :)
0
 
DaveCommented:
No probs :)
The code below autfotites the Stat sheet in columns A:G by using
objWorksheet2.Columns("A:G").AutoFit
Plus I have havr eremoved turning autofilter off by taking out this line
objWorksheet.AutoFilterMode = False
 
Cheers
Dave

Dim objExcel, objWorkbook, objWorksheet
Dim objWorksheet2, objRange, objRange2
Dim rngAddy, rngAddy2
Dim Headers
Headers = Array("Manufacturer", "CIPUPD Revenue", "Machine Count", "Unique Mfrs", "     ", "Avg Per Ship", "Avg Per Machine")
Set objExcel = CreateObject("Excel.Application")
Set objWorkbook = objExcel.Workbooks.Open("D:\Dailyslotreports.xls")
On Error Resume Next
objExcel.DisplayAlerts = False
objWorkbook.Sheets("Stats").Delete
On Error GoTo 0
Set objWorksheet = objWorkbook.Worksheets(1)
Set objRange = objExcel.Range(objWorksheet.Range("E1"), objWorksheet.Range("E1").End(-4121))
Set objWorksheet2 = objWorkbook.Worksheets.Add
objWorksheet2.Name = "Stats"
With objRange
    .AdvancedFilter 1, , , True
    .Copy objWorksheet2.Range("A1")
End With
On Error Resume Next
Set objRange2 = objWorksheet2.Columns("A").SpecialCells(xlBlanks)
objRange2.EntireRow.Delete
On Error GoTo 0
Set objRange2 = objExcel.Range(objWorksheet2.Range("A2"), objWorksheet2.Range("A2").End(-4121))
rngAddy = "'" & objRange.Parent.Name & "'!" & objRange.Address(, , -4150)
rngAddy2 = "'" & objRange.Parent.Name & "'!" & objRange.Offset(0, 9).Address(, , -4150)
objRange2.Offset(0, 2).FormulaR1C1 = "=COUNTIF(" & rngAddy & ",'Stats'!RC1)"
objRange2.Offset(0, 1).FormulaR1C1 = "=SUMIF(" & rngAddy & ",'Stats'!RC1," & rngAddy2 & ")"
objRange2.Offset(0, 5).FormulaR1C1 = "=SUMIF(" & rngAddy & ",'Stats'!RC1," & rngAddy2 & ")/9"
objRange2.Offset(0, 6).FormulaR1C1 = "=SUMIF(" & rngAddy & ",'Stats'!RC1," & rngAddy2 & ")/COUNTIF(" & rngAddy & ",'Stats'!RC1)"
objWorksheet2.Range("A1:G1") = Headers
objWorksheet2.Columns("A:G").AutoFit
objWorksheet2.Range("D2") = objWorksheet2.UsedRange.Rows.Count - 1
objWorkbook.Save
objWorkbook.Close False
objExcel.DisplayAlerts = True
objExcel.Quit
Set objExcel = Nothing

Open in new window

0
 
smyers051972Author Commented:
Thank you again Dave! P.S. could you check out my other Question when you have a chance, I am not totally sure whats being said in regards to moving yellow colored (fills) of rows to the top (2nd row - 1 below headers) on excel, its baffling me. Thanks!
0
 
DaveCommented:
thx for the grade :)

will check out the other q

Cheers

Dave
0
 
smyers051972Author Commented:
Thanks Dave! I have 2 open now :)
0
Question has a verified solution.

Are you are experiencing a similar issue? Get a personalized answer when you ask a related question.

Have a better answer? Share it in a comment.

Join & Write a Comment

Featured Post

Free Tool: Subnet Calculator

The subnet calculator helps you design networks by taking an IP address and network mask and returning information such as network, broadcast address, and host range.

One of a set of tools we're offering as a way of saying thank you for being a part of the community.

  • 12
  • 6
  • 2
Tackle projects and never again get stuck behind a technical roadblock.
Join Now