OGSan
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(S heets.Coun t))
The error message issued is, Microsoft VBScript compilation error: Expected ')'
Can an Expert help me translate this into executable code for me?
Thank you!
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
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...!
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
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
In this case your Excel instance in objExcel
so you can do this
If objexcel.Intersect(.UsedRange, .Range("I3:I65536")) Is Nothing Then
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
Once you remedy that issue, you may find others that are similar in nature.
Chris
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.Inter sect ...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...
If objExcel.Intersect ...blah-blah-blah and got an error so I changed it to...
If objExcel.ActiveSheet.Inter
"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
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
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.
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
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
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
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."
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
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
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.
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
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
ASKER
Yeehaw! Thanks, Dave. It works - BUT - each worksheet is missing one row. Maybe it's the offset...???
ASKER
Oh, and each worksheet is missing the header row...(sorry!).
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
The test file below has different item numbers.
ZZ-COUNT-SHEET-NON-STAGING.xls
ASKER CERTIFIED SOLUTION
membership
This solution is only available to members.
To access this solution, you must be a member of Experts Exchange.
ASKER
You da MAN!
It is now working like I envisioned.
Thank you SO much, Dave.
Jeff (aka OGSan)
It is now working like I envisioned.
Thank you SO much, Dave.
Jeff (aka OGSan)
ASKER
Excellent and Expert help from the Genius himself, Dave!
No probs Jeff - thanks for the appreciative feedback :)
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
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
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
Open in new window