Solved

VBScript to add worksheets based on value in a column

Posted on 2010-09-23
21
1,883 Views
Last Modified: 2014-03-05
I am inserting some new code into a working automation script that is attempting to add a new worksheet for each new value found in column I of the active worksheet.  It works as a macro, but I'm trying to make it work inside of a stand-alone script.  The code does not complie and gets hung up on line 19:  Set WS = Sheets.Add(After:=Sheets(Sheets.Count))
The error message issued is, Microsoft VBScript compilation error: Expected ')'  
Can an Expert help me translate this into executable code for me?
Thank you!

' T E S T I N G    -   B E G I N 

' Creates a new worksheet for every Level 1 value in Column I

' Also assumes presence of header rows in rows 1-2 of your source spreadsheet.

'

Dim CLL

Dim WS



With objExcel.ActiveSheet 

	Set CLL = .Range("A3") 

	If Intersect(.UsedRange, .Range("I3:I65536")) Is Nothing Then

 	' Dont do anything

 	Else

 		For Each CLL In Intersect(.UsedRange, .Range("I3:I65536"))

  			Set WS = Nothing

  			On Error Resume Next

  			Set WS = Sheets(CLL.Text)

  			On Error GoTo 0

  			If WS Is Nothing Then

   				Set WS = Sheets.Add(After:=Sheets(Sheets.Count))

   				sWS.Rows(1).Copy WS.Rows(1)

   				WS.Name = IBU & "Aisle " & CLL.Text

  			End If

  		CLL.EntireRow.Copy WS.Range("I65536").End(xlUp).Offset(1, 0).EntireRow

 		Next 'cll

 	End If

End With

' T E S T I N G   -   E N D

Open in new window

0
Comment
Question by:OGSan
21 Comments
 
LVL 50

Expert Comment

by:Dave Brett
ID: 33750929
This should help

A couple of things

You can't use After like you do in VBA
You should fully referebce the sheet object (by using the wb object)

Cheers

Dave

Dim objExcel
Dim WB
Dim ws

Set objExcel = CreateObject("excel.application")

objExcel.Visible = True
Set WB = objExcel.Workbooks.Open("C:\test.xls")
Set ws = objExcel.Sheets.Add(, wb.Sheets(wb.Sheets.Count))

Open in new window

0
 
LVL 1

Author Comment

by:OGSan
ID: 33750977
Thanks, Dave.
I tweaked the code slightly so it reads as per below.
It now complies, but I get a run time error, Type Mismatch: 'Intersect'
Sorry, I don't have a clue on this...!
' T E S T I N G    -   B E G I N 

' Creates a new worksheet for every Level 1 value in Column I

' Also assumes presence of header rows in rows 1-2 of your source spreadsheet.

'

Dim CLL

Dim WS



With objExcel.ActiveSheet 

	Set CLL = .Range("A3") 

	If Intersect(.UsedRange, .Range("I3:I65536")) Is Nothing Then

 	' Dont do anything

 	Else

 		For Each CLL In Intersect(.UsedRange, .Range("I3:I65536"))

  			Set WS = Nothing

  			On Error Resume Next

  			Set WS = Sheets(CLL.Text)

  			On Error GoTo 0

  			If WS Is Nothing Then

   				Set WS = Sheets.Add(, .Sheets(.Sheets.Count))

   				sWS.Rows(1).Copy WS.Rows(1)

   				WS.Name = IBU & "Aisle " & CLL.Text

  			End If

  		CLL.EntireRow.Copy WS.Range("I65536").End(xlUp).Offset(1, 0).EntireRow

 		Next 'cll

 	End If

End With

' T E S T I N G   -   E N D

Open in new window

0
 
LVL 1

Author Comment

by:OGSan
ID: 33750978
This is at line 10 above.
0
 
LVL 50

Expert Comment

by:Dave Brett
ID: 33750990
That is because the Intersect should be proceeded with the Application when automating

In this case your Excel instance in objExcel

so you can do this

If objexcel.Intersect(.UsedRange, .Range("I3:I65536")) Is Nothing Then

Open in new window

0
 
LVL 6

Expert Comment

by:CRJ2000
ID: 33750996
Try putting "objExcel.Intersect" in place of "Intersect" -- VBS doesn't inherently know anything about the Excel object library, so it doesn't know what the word "Intersect" means.

Once you remedy that issue, you may find others that are similar in nature.

Chris
0
 
LVL 1

Author Comment

by:OGSan
ID: 33751019
Thanks Dave & Chris - I changed the code to read...
If objExcel.Intersect ...blah-blah-blah  and got an error so I changed it to...
If objExcel.ActiveSheet.Intersect ...blah-blah-blah and still got the same error - which was:
"Object doesn't support this property or method: objExcel.Intersect"
Thanks in advance for hanging in there with me...
0
 
LVL 50

Expert Comment

by:Dave Brett
ID: 33751028
My code worked on my test which was as below (given I dont have your Excel file to run )

Maybe you could post your file?

Cheers

Dave

Dim objExcel
Dim WB
Dim ws


Set objExcel = CreateObject("excel.application")

objExcel.Visible = True
Set WB = objExcel.Workbooks.Open("C:\test.xls")
Set ws = objExcel.Sheets.Add(, wb.Sheets(wb.Sheets.Count))

With objExcel.ActiveSheet 
	Set CLL = .Range("A3") 
	If objexcel.Intersect(.UsedRange, .Range("I3:I65536")) Is Nothing Then msgbox "Yes"
end with

Open in new window

0
 
LVL 1

Author Comment

by:OGSan
ID: 33751043
I've posted the complete script below.
The portion that I'm having a problem with is bracketed by "T E S T."
Everything above and below that bracketed code works fine.
I've also attached the sample file that it opens and, in the end, saves as a renamed file.
'==========================================================================

' AutomationScript_Format_NON_STAGING.vbs

'

' This VBScript will:

' 1.  Open the PeopleSoft extract file created by two queries:

'     ZZ_COUNT_SHEET_NON_STAGING 

'     This query contains information needed to conduct the physical inventory of items inside the various

'     warehouse locations (aka "IBU"s).

' 2.  Depending on which worksheet is opened, this script will:

'     A.  Insert new columns with column headers and formulas necessary for taking the physical inventory.

'     B.  Print out only specific columns required for taking the physical inventory.

'

' 09/01/10 JTF Creation date

'

' 09/09/10 JTF Additional columns were added to NON-STAGING query so this module had to be adjusted for them.

'

' 09/23/10 JTF Variance formula's IF changed to check for NULLS instead of a Zero (since Zero count is a valid value)

'              Also fixed bug where if only one row of data, inserted formulas were duplicating header row instead (!?)

'

' 09/23/10 JTF For IBU's HEU10 and/or HI100, there are a large number of items (over 1000 each).  In order to provide

'              discipline to the inventory process, this script needs to break-out the item inventory by AISLE (Level 1 value).

'              Modified to create a separate worksheet tab for each Level 1 value.

'              Original worksheet must serve as a "Master Roll-up" that picks up the manually entered values from each individual

'              worksheet.

' 

'==========================================================================

' Open the Excel Spreadsheet

Set objExcel = CreateObject("Excel.Application")

'Set objWorkbook = objExcel.Workbooks.Open("\\nfs1\dept\purchasing\_Reporting_Periodic\Annual_InventoryWorksheets\ZZ_COUNT_SHEET_NON_STAGING.xls")

'TEST   

Set objWorkbook = objExcel.Workbooks.Open("C:\ZZ_COUNT_SHEET_NON_STAGING.xls")



'Insert columns required for physical inventory of the items on this worksheet

Dim variance_frmla

Dim valuation_frmla

Dim i 

Dim rg 



'Disable screenupdating so the code runs faster

objExcel.ScreenUpdating = False



'Insert column headers beginning in Cell X2

objExcel.Cells(2, 24).Value = "Notes"

objExcel.Cells(2, 25).Value = "Count1"

objExcel.Cells(2, 26).Value = "Variance1 [Count Qty] - [Count1]"

objExcel.Cells(2, 27).Value = "Valuation1 [Variance1] X [Unit Cost]"

objExcel.Cells(2, 28).Value = "Count2"

objExcel.Cells(2, 29).Value = "Variance2 [Count Qty] - [Count2]"

objExcel.Cells(2, 30).Value = "Valuation2 [Variance2] X [Unit Cost]"

objExcel.Cells(2, 31).Value = "Count3"

objExcel.Cells(2, 32).Value = "Variance3 [Count Qty] - [Count3]"

objExcel.Cells(2, 33).Value = "Valuation3 [Variance3] X [Unit Cost]"



'Apply formatting across the column headers X2:AG2

With objExcel.ActiveSheet

	Set rg = .Range("X2:AG2")

    rg.Interior.ColorIndex = 35

    rg.Font.ColorIndex = 25

    rg.Font.Bold = True

    rg.Font.Size = 10

	rg.Borders.LineStyle = 9  '7 = single line, 8 = dashed, 9 = double

    rg.NumberFormat = "general"

End With



'Insert the Variance & Valuation formulas into adjacent cells beginning with Y3

With objExcel.ActiveSheet

    Set rg = .Range("Y3")



'Insert the Variance & Valuation formulas into adjacent cells beginning with Z3

        variance_frmla = "=IF(Y3="""",0,$R3-Y3)"

        valuation_frmla = "=IF(Y3="""",0,($R3-Y3)*$W3)"



        rg.Offset(0, 1).Formula = variance_frmla

        rg.Offset(0, 1).Copy

        rg.Offset(0, 4).PasteSpecial -4123 ' - 4123 = xlPasteFormulas

        rg.Offset(0, 7).PasteSpecial -4123

        rg.Offset(0, 2).Formula = valuation_frmla

        rg.Offset(0, 2).Copy

        rg.Offset(0, 5).PasteSpecial -4123

        rg.Offset(0, 8).PasteSpecial -4123

End With



'This copies the formulas all the way down cols Y thru AG

With objExcel.ActiveSheet

    Set rg = .Range("Y3")

    Set rg = .Range(rg, .Cells(.Cells(.Rows.Count, 1).End(-4162).Row, rg.Column)) 'xLUp = -4162

'    Debug.Print rg.Address



'   Only do the FillDown if there is more than one row, otherwise you are done

	If  rg.Rows.Count > 1 Then

    	With rg.Offset(0, -1).Resize(, 10)

        	.FillDown

'>>> OMIT (this is equivalent to doing PasteSpecial->Values)    .Formula = .Value

    	End With

    End If

End With





' T E S T I N G    -   B E G I N 

' Creates a new worksheet for every Level 1 value in Column I

' Also assumes presence of header rows in rows 1-2 of your source spreadsheet.

'

Dim CLL

Dim WS



With objExcel.ActiveSheet 

	Set CLL = .Range("A3") 

	If objExcel.ActiveSheet.Intersect(.UsedRange, .Range("I3:I65536")) Is Nothing Then

 	' Dont do anything

 	Else

 		For Each CLL In Intersect(.UsedRange, .Range("I3:I65536"))

  			Set WS = Nothing

  			On Error Resume Next

  			Set WS = Sheets(CLL.Text)

  			On Error GoTo 0

  			If WS Is Nothing Then

   				Set WS = Sheets.Add(, .Sheets(.Sheets.Count))

   				.Rows(1).Copy WS.Rows(1)

   				WS.Name = IBU & "Aisle " & CLL.Text

  			End If

  		CLL.EntireRow.Copy WS.Range("I65536").End(xlUp).Offset(1, 0).EntireRow

 		Next 'cll

 	End If

End With

' T E S T I N G   -   E N D







' Retrieve the separate Date components. 

Dim TodayYYYY, TodayMM, TodayDD

TodayYYYY = Year(Date) 

TodayMM   = Month(Date) 

TodayDD   = Day(Date) 



' Retrieve the IBU value from cell A3 for use in the file-name

Dim IBU

IBU = objExcel.Cells(3, 1).Value



' Save the sheet - appending TodaysDate to the end of the file-name.

'objWorkbook.SaveAs "\\nfs1\dept\purchasing\_Reporting_Periodic\Annual_InventoryWorksheets\Inventory_Worksheets (NON-STAGING)\ZZ_COUNT_SHEET_NON_STAGING_" & IBU & "_" & TodayYYYY & "-" & TodayMM & "-" & TodayDD & ".xls"

'TEST    

objWorkbook.SaveAs "C:\" & IBU & "_ZZ_COUNT_SHEET_NON_STAGING_" & TodayYYYY & "-" & TodayMM & "-" & TodayDD & ".xls"



' Set print options

With objExcel.ActiveSheet.PageSetup            

                .PrintTitleRows = "$1:$2"

                .PrintTitleColumns = ""

				.PrintArea = ""  

                .LeftHeader = ""

                .CenterHeader = ""

                .RightHeader = ""

                .LeftFooter = "&F"

                .CenterFooter = "Page &P of &N"

                .RightFooter = "&D"

                .LeftMargin = 0

                .RightMargin = 0

                .TopMargin = 36

                .BottomMargin = 36

                .HeaderMargin = 18

                .FooterMargin = 18

        		.Orientation = 2 '2 = Landscape, omit setting for portrait default

                .PrintHeadings = False

                .PrintGridlines = True

                .CenterHorizontally = True

                .CenterVertically = False

                .FirstPageNumber = "1"

                .BlackAndWhite = False

                .Zoom = 85

End With

'Autofit columns 

objExcel.Cells.Select

objExcel.Selection.Columns.AutoFit



' Print only desired columns for physical inventory (to fit on clipboard)

objExcel.ActiveSheet.Columns("C:C").Select

objExcel.Selection.EntireColumn.Hidden = True



objExcel.ActiveSheet.Columns("F:F").Select

objExcel.Selection.EntireColumn.Hidden = True



objExcel.Columns("L:P").Select

objExcel.Selection.EntireColumn.Hidden = True



objExcel.Columns("R:W").Select

objExcel.Selection.EntireColumn.Hidden = True



objExcel.Columns("Z:AG").Select

objExcel.Selection.EntireColumn.Hidden = True



'Set column A's width 

objExcel.Columns("A:A").ColumnWidth = 9



'Set column W's width 

objExcel.Columns("X:X").ColumnWidth = 26 



' Print the worksheet

objExcel.ActiveSheet.Printout



'Autofit columns - RESET to expose all columns before saving again

objExcel.Cells.Select

objExcel.Selection.Columns.AutoFit

objExcel.Columns("X:X").ColumnWidth = 26 



' Save the sheet - appending TodaysDate to the end of the file-name.

objWorkbook.Save



 

'Must turn screenupdating back on

objExcel.ScreenUpdating = True



' Close Excel with the Quit method on the Application object.

objWorkbook.Application.Quit



' Release the object variable.

Set objExcel = Nothing

Open in new window

ZZ-COUNT-SHEET-NON-STAGING.xls
0
 
LVL 50

Expert Comment

by:Dave Brett
ID: 33751080
pls try this

I've added in the objworkbook workbook object below (I used wb in my initial test code)
changed the xlup to -4162

Cheers

Dave

Dim CLL
Dim WS

Set objexcel = CreateObject("Excel.Application")
'Set objWorkbook = objExcel.Workbooks.Open("\\nfs1\dept\purchasing\_Reporting_Periodic\Annual_InventoryWorksheets\ZZ_COUNT_SHEET_NON_STAGING.xls")
'TEST
Set objworkbook = objexcel.Workbooks.Open("C:\test\ZZ-COUNT-SHEET-NON-STAGING.xls")

With objexcel.ActiveSheet
    Set CLL = .Range("A3")
    If objexcel.Intersect(.UsedRange, .Range("I3:I65536")) Is Nothing Then
    ' Dont do anything
    Else
        For Each CLL In objexcel.Intersect(.UsedRange, .Range("I3:I65536"))
            Set WS = Nothing
            On Error Resume Next
            Set WS = objworkbook.Sheets(CLL.Text)
            On Error GoTo 0
            If WS Is Nothing Then
                Set WS = objworkbook.Sheets.Add(, objworkbook.Sheets(objworkbook.Sheets.Count))
                .Rows(1).Copy WS.Rows(1)
                WS.Name = IBU & "Aisle " & CLL.Text
            End If
        CLL.EntireRow.Copy WS.Range("I65536").End(-4162).Offset(1, 0).EntireRow
        Next 'cll
    End If
End With

Open in new window

0
 
LVL 1

Author Comment

by:OGSan
ID: 33751095
Woot!  Almost there, Dave!
Code gets hung on Line 22 above where I'm trying to rename the worksheet tab using the IBU value and then the literal "Aisle" followed by the value from column I.
So the first worksheet tab should be named, "HEU25 Aisle 12".
The error I am getting reads,
"Cannot rename a sheet to the same name as another sheet, a referenced object library or a workbook referenced by Visual Basic."
0
IT, Stop Being Called Into Every Meeting

Highfive is so simple that setting up every meeting room takes just minutes and every employee will be able to start or join a call from any room with ease. Never be called into a meeting just to get it started again. This is how video conferencing should work!

 
LVL 50

Expert Comment

by:Dave Brett
ID: 33751145
You have duplicate rows in your sample file, ie I3 and I4 both have
12
So the code tries to create two sheets called
Aisle 12
hence the error

is this a sample data issue, or do you need to handle duplicates differently, ie put both these rows (and I5-I7) on the Aisle 12 sheet?

Dave
0
 
LVL 1

Author Comment

by:OGSan
ID: 33751160
I commented out the rename line and the code was trying to create one worksheet for each row.
But what I am trying to do is create one worksheet for each change in the value of Level 1 (in column I).
So there should wind up being three (3) new worksheets:
HEU25 Aisle 12 - This should have five rows.
HEU25 Aisle 13 - This should have seven rows.
HEU25 Aisle 17 - This should have four rows.
Thanks for hanging with me, Dave.
0
 
LVL 50

Expert Comment

by:Dave Brett
ID: 33751178
Got it :)

here it is

Sub a()
    Dim CLL
    Dim WS

    Set objexcel = CreateObject("Excel.Application")
    'Set objWorkbook = objExcel.Workbooks.Open("\\nfs1\dept\purchasing\_Reporting_Periodic\Annual_InventoryWorksheets\ZZ_COUNT_SHEET_NON_STAGING.xls")
    'TEST
    Set objworkbook = objexcel.Workbooks.Open("C:\test\ZZ-COUNT-SHEET-NON-STAGING.xls")
    objexcel.Visible = True
    With objexcel.ActiveSheet
        Set CLL = .Range("A3")
        If objexcel.Intersect(.UsedRange, .Range("I3:I65536")) Is Nothing Then
            ' Dont do anything
        Else
            For Each CLL In objexcel.Intersect(.UsedRange, .Range("I3:I65536"))
                Set WS = Nothing
                On Error Resume Next
                Set WS = objworkbook.Sheets("Aisle " & CLL.Text)
                On Error GoTo 0
                If WS Is Nothing Then
                    Set WS = objworkbook.Sheets.Add(, objworkbook.Sheets(objworkbook.Sheets.Count))
                    .Rows(1).Copy WS.Rows(1)
                    WS.Name = IBU & "Aisle " & CLL.Text
                Else
                    CLL.EntireRow.Copy WS.Range("I65536").End(-4162).Offset(1, 0).EntireRow
                End If

            Next    'cll
        End If
    End With
End Sub

Open in new window

0
 
LVL 1

Author Comment

by:OGSan
ID: 33751203
Yeehaw!  Thanks, Dave.  It works - BUT - each worksheet is missing one row.  Maybe it's the offset...???
0
 
LVL 1

Author Comment

by:OGSan
ID: 33751234
Oh, and each worksheet is missing the header row...(sorry!).
0
 
LVL 1

Author Comment

by:OGSan
ID: 33751278
I found out that it is always the first row that is not included in each worksheet.
The test file below has different item numbers.
ZZ-COUNT-SHEET-NON-STAGING.xls
0
 
LVL 50

Accepted Solution

by:
Dave Brett earned 500 total points
ID: 33751286
If you want the first two rows as header use this
.Rows("1:2").Copy WS.Rows("1:2")
as below

Cheers

Dave


Dim CLL
    Dim WS

    Set objexcel = CreateObject("Excel.Application")
    'Set objWorkbook = objExcel.Workbooks.Open("\\nfs1\dept\purchasing\_Reporting_Periodic\Annual_InventoryWorksheets\ZZ_COUNT_SHEET_NON_STAGING.xls")
    'TEST
    Set objworkbook = objexcel.Workbooks.Open("C:\test\ZZ-COUNT-SHEET-NON-STAGING.xls")
    objexcel.Visible = True
    With objexcel.ActiveSheet
        Set CLL = .Range("A3")
        If objexcel.Intersect(.UsedRange, .Range("I3:I65536")) Is Nothing Then
            ' Dont do anything
        Else
            For Each CLL In objexcel.Intersect(.UsedRange, .Range("I3:I65536"))
                Set WS = Nothing
                On Error Resume Next
                Set WS = objworkbook.Sheets("Aisle " & CLL.Text)
                On Error GoTo 0
                If WS Is Nothing Then
                    Set WS = objworkbook.Sheets.Add(, objworkbook.Sheets(objworkbook.Sheets.Count))
                    .Rows("1:2").Copy WS.Rows("1:2")
                     CLL.EntireRow.Copy WS.Range("I65536").End(-4162).Offset(1, 0).EntireRow
                    WS.Name = IBU & "Aisle " & CLL.Text
                Else
                    CLL.EntireRow.Copy WS.Range("I65536").End(-4162).Offset(1, 0).EntireRow
                End If

            Next    'cll
        End If
    End With

Open in new window

0
 
LVL 1

Author Comment

by:OGSan
ID: 33751301
You da MAN!
It is now working like I envisioned.
Thank you SO much, Dave.
Jeff (aka OGSan)
0
 
LVL 1

Author Closing Comment

by:OGSan
ID: 33751302
Excellent and Expert help from the Genius himself, Dave!
0
 
LVL 50

Expert Comment

by:Dave Brett
ID: 33751401
No probs Jeff - thanks for the appreciative feedback :)
0
 

Expert Comment

by:adirisin
ID: 39906079
Hi Dave,

I have a similar query, the only difference is that i need to create a new workbook for each unique value and the name of the workbook should be this unique value.

Please advice.

thanks in advane!
Aditya
0

Featured Post

How your wiki can always stay up-to-date

Quip doubles as a “living” wiki and a project management tool that evolves with your organization. As you finish projects in Quip, the work remains, easily accessible to all team members, new and old.
- Increase transparency
- Onboard new hires faster
- Access from mobile/offline

Join & Write a Comment

Suggested Solutions

Deploying a Microsoft Access application in a Citrix environment is not difficult but takes a few steps. However, Citrix system people are often of little help, as they typically know next to nothing about Access. The script provided here will take …
If you need to start windows update installation remotely or as a scheduled task you will find this very helpful.
The view will learn how to download and install SIMTOOLS and FORMLIST into Excel, how to use SIMTOOLS to generate a Monte Carlo simulation of 30 sales calls, and how to calculate the conditional probability based on the results of the Monte Carlo …
This Micro Tutorial will demonstrate the scrolling table in Microsoft Excel using the INDEX function.

707 members asked questions and received personalized solutions in the past 7 days.

Join the community of 500,000 technology professionals and ask your questions.

Join & Ask a Question

Need Help in Real-Time?

Connect with top rated Experts

14 Experts available now in Live!

Get 1:1 Help Now