Link to home
Start Free TrialLog in
Avatar of OGSan
OGSanFlag for United States of America

asked on

VBScript to add worksheets based on value in a column

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

Avatar of Dave
Dave
Flag of Australia image

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

Avatar of OGSan

ASKER

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

Avatar of OGSan

ASKER

This is at line 10 above.
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

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
Avatar of OGSan

ASKER

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

Avatar of OGSan

ASKER

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

Avatar of OGSan

ASKER

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."
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
Avatar of OGSan

ASKER

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

Avatar of OGSan

ASKER

Yeehaw!  Thanks, Dave.  It works - BUT - each worksheet is missing one row.  Maybe it's the offset...???
Avatar of OGSan

ASKER

Oh, and each worksheet is missing the header row...(sorry!).
Avatar of OGSan

ASKER

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
ASKER CERTIFIED SOLUTION
Avatar of Dave
Dave
Flag of Australia image

Link to home
membership
This solution is only available to members.
To access this solution, you must be a member of Experts Exchange.
Start Free Trial
Avatar of OGSan

ASKER

You da MAN!
It is now working like I envisioned.
Thank you SO much, Dave.
Jeff (aka OGSan)
Avatar of OGSan

ASKER

Excellent and Expert help from the Genius himself, Dave!
No probs Jeff - thanks for the appreciative feedback :)
Avatar of adirisin
adirisin

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