Solved

VBScript to add worksheets based on value in a column

Posted on 2010-09-23
21
1,959 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
[X]
Welcome to Experts Exchange

Add your voice to the tech community where 5M+ people just like you are talking about what matters.

  • Help others & share knowledge
  • Earn cash & points
  • Learn & ask questions
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
Salesforce Made Easy to Use

On-screen guidance at the moment of need enables you & your employees to focus on the core, you can now boost your adoption rates swiftly and simply with one easy tool.

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

Technology Partners: We Want Your Opinion!

We value your feedback.

Take our survey and automatically be enter to win anyone of the following:
Yeti Cooler, Amazon eGift Card, and Movie eGift Card!

Question has a verified solution.

If you are experiencing a similar issue, please ask a related question

How to get Spreadsheet Compare 2016 working with the 64 bit version of Office 2016
In Part II of this series, I will discuss how to identify all open instances of Excel and enumerate the workbooks, spreadsheets, and named ranges within each of those instances.
This Micro Tutorial will demonstrate how to use longer labels with horizontal bar charts instead of the vertical column chart.
Finds all prime numbers in a range requested and places them in a public primes() array. I've demostrated a template size of 30 (2 * 3 * 5) but larger templates can be built such 210  (2 * 3 * 5 * 7) or 2310  (2 * 3 * 5 * 7 * 11). The larger templa‚Ķ

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