asked on

.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!

Dave

Yep, this is soundling a little tricky :)
Do you have sample file (before and final) to help guide us?
Cheers
Dave

wobbled

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

wobbled

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?

smyers051972

ASKER

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!

Dave

Pls upload the sheet. It will help with the problem part in (3) and (4)
Cheers
Dave

smyers051972

ASKER

Will do dave, headed to work in a few minutes here!

Dave

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 :)

smyers051972

ASKER

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

smyers051972

ASKER

Let me re-upload, I forgot the mock up of sheet1, now its included.

Thanks!

sample-players.xls

smyers051972

ASKER

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!

Dave

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

smyers051972

ASKER

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

smyers051972

ASKER

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!

smyers051972

ASKER

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

smyers051972

ASKER

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

smyers051972

ASKER

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 :)

ASKER CERTIFIED SOLUTION

Dave

membership

This solution is only available to members.

To access this solution, you must be a member of Experts Exchange.

Start Free Trial

smyers051972

ASKER

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!

Dave

thx for the grade :)

will check out the other q

Cheers

Dave

smyers051972

ASKER

Thanks Dave! I have 2 open now :)