Getting error no 1004 while running VBA code - vba

I was running a VBA code in Excel 2007. I got the above mention run/Application error of 1004.
My code is
Public Sub LblImport_Click()
Dim i As Long, j As Long
Dim vData As Variant, vCleanData As Variant, vFile As Variant, sMarket As String
Dim wbkExtract As Workbook, sLastCellAddress As String, month As String
Dim cnCountries As New Collection
Application.ScreenUpdating = False
' Get the name of the Dataview Extract file to transform and the market name
vFile = "D:\DRX\" & "Norvasc_Formatted.xlsx"
sMarket = "Hypertension"
ThisWorkbook.Worksheets("Control").Range("TherapeuticMarket").Value = "Hypertension"
' Clear all existing data from this workbook
ThisWorkbook.Worksheets("RawData").Cells.ClearContents
' Create labels in Raw Data Sheet
ThisWorkbook.Worksheets("RawData").Cells(1, 1).Value = "Therapy Market"
ThisWorkbook.Worksheets("RawData").Cells(1, 2).Value = "Country"
ThisWorkbook.Worksheets("RawData").Cells(1, 3).Value = "Brand"
ThisWorkbook.Worksheets("RawData").Cells(1, 4).Value = "Corporation"
ThisWorkbook.Worksheets("RawData").Cells(1, 5).Value = "Molecule"
' Open Dataview extract, copy and clean data
Set wbkExtract = Workbooks.Open(vFile)
i = 2
Do While wbkExtract.ActiveSheet.Cells(1, i).Value <> ""
If UCase(Mid(wbkExtract.ActiveSheet.Cells(1, i).Value, 1, 3)) = "TRX" Then
month = Split(wbkExtract.ActiveSheet.Cells(1, i).Value, "/")(1)
If Len(month) = 1 Then
month = "0" + month
End If
ThisWorkbook.Worksheets("RawData").Cells(1, i + 4).Value = Mid(wbkExtract.ActiveSheet.Cells(1, i).Value, 1, 10) + month + "/" + Mid(Split(wbkExtract.ActiveSheet.Cells(1, i).Value, "/")(2), 3, 2)
End If
If UCase(Mid(wbkExtract.ActiveSheet.Cells(1, i).Value, 1, 3)) = "LCD" Then
month = Split(wbkExtract.ActiveSheet.Cells(1, i).Value, "/")(2)
If Len(month) = 1 Then
month = "0" + month
End If
ThisWorkbook.Worksheets("RawData").Cells(1, i + 4).Value = Mid(wbkExtract.ActiveSheet.Cells(1, i).Value, 1, 14) + month + "/" + Mid(Split(wbkExtract.ActiveSheet.Cells(1, i).Value, "/")(3), 3, 2)
End If
i = i + 1
Loop
wbkExtract.ActiveSheet.Cells(1, 1).EntireRow.Delete
vData = wbkExtract.ActiveSheet.Cells(1, 1).CurrentRegion.Value
wbkExtract.Close savechanges:=False
vCleanData = CleanRawData(vData, sMarket)
sLastCellAddress = ThisWorkbook.Worksheets("RawData").Cells(UBound(vCleanData, 1) + 1, UBound(vCleanData, 2)).Address(RowAbsolute:=False, ColumnAbsolute:=False)
ThisWorkbook.Worksheets("RawData").Range("A2:" & sLastCellAddress).Value = vCleanData
' Get List of Unique Countries
On Error Resume Next
For i = 1 To UBound(vCleanData, 1)
cnCountries.Add vCleanData(i, 2), vCleanData(i, 2)
Next i
On Error GoTo 0
ThisWorkbook.Worksheets("Market").Cells(1, 1).CurrentRegion.Clear
ThisWorkbook.Worksheets("Market").Cells(1, 1).Value = "Country"
ThisWorkbook.Worksheets("Market").Cells(1, 2).Value = "Group 1"
ThisWorkbook.Worksheets("Market").Cells(1, 3).Value = "Group 2"
ThisWorkbook.Worksheets("Market").Cells(1, 4).Value = "Group 3"
ThisWorkbook.Worksheets("Market").Cells(1, 5).Value = "Group 4"
ThisWorkbook.Worksheets("Market").Range("A1:G1").Font.Bold = True
For i = 1 To cnCountries.Count
ThisWorkbook.Worksheets("Market").Cells(i + 1, 1).Value = cnCountries.Item(i)
Next i
End Sub

Sounds like a broken code cache.
I've seen errors happen like this before in older format (xls) workbooks and it can be a sign of problems in the file overall.
Try the compile option suggested by #Scott Holtzman first. In some cases I've seen the recompile not work and if that happens just force a compile by making a change to the code. A trivial change is enough usually.
If that doesn't work then (to help disagnose a corruption issue) try copying the code into a new workbook and see what happens there. If it runs in the new sheet then I wouldn't waste more time on it and just rebuild the sheet, trust me it'll be quicker than messing about troublshooting the one you have.

Related

Add Check Boxes to a userform with multiple sections that will input a number located on Sheet

I am new to VBA, and I am working on a userform, which was created by someone else. The userform has four areas(Cost Code1, Cost Code 2, exc...) that input information(Cost Code, Truck Rent, Regular Hours and Overtime Hours) into specific columns on the worksheet. Right now there are text boxes at the top of the form that enters the employee name, job number and date with all of the information.
The new project has two job numbers, so instead of using the Job Number Text Box at the top, I need to add Option Buttons, or Check Boxes (whichever is easier) to choose between the two different job numbers for the four groups of information. I would like to only be allowed to select one job number per area on the userform. The job numbers will be located on a second tab called Employees in cells H1 and K1. I need the job number to be entered in column number 4. What is the code for the Check Boxes, or Option Buttons, and where would I enter it in the original code? I appreciate any help.
Private Sub cbOK_Click()
Dim NextRow As Long
'Variable for cycling through cell input
Dim i As Long
Dim Userdate As Date
i = 1
Set EESheet = ActiveWorkbook.Sheets("Employees")
Set TLISheet = ActiveWorkbook.Sheets("Worksheet")
'Activate Worksheet Tab
Sheets("Worksheet").Activate
'Set Autocalc off to speed things up.
Application.Calculation = xlCalculationManual
'Error Handling, go to bad.
On Error GoTo Bad
Userdate = tbDate.Value
'Transfer the data to the rows
For i = 1 To 6
NextRow = Application.WorksheetFunction.CountA(Range("A:A")) + 1
If Me.Controls("tbCC" & i & "RegHrs").Value <> "" Then
Cells(NextRow, 1) = tbDate.Value
Cells(NextRow, 2) = cmbEmployeeName.Value
Cells(NextRow, 3) = Application.WorksheetFunction.VLookup(cmbEmployeeName.Value, EESheet.Range("A:B"), 2, False)
Cells(NextRow, 4) = tbJobNumber.Value
Cells(NextRow, 5) = Me.Controls("tbJobExtra" & i).Value
Cells(NextRow, 6) = Me.Controls("cmbCC" & i).Value
Cells(NextRow, 7) = Application.WorksheetFunction.VLookup(cmbEmployeeName.Value, EESheet.Range("A:C"), 3, False)
Cells(NextRow, 8) = Application.WorksheetFunction.VLookup(cmbEmployeeName.Value, EESheet.Range("A:D"), 4, False)
Cells(NextRow, 10) = Application.WorksheetFunction.VLookup(cmbEmployeeName.Value, EESheet.Range("A:E"), 5, False)
If EEtype = 1 Then
Cells(NextRow, 9) = "SOH"
Else
Cells(NextRow, 9) = "REG"
End If
Cells(NextRow, 10) = Me.Controls("tbCC" & i & "RegHrs").Value
End If
If Me.Controls("tbCC" & i & "OTHrs").Text <> "" Then
NextRow = Application.WorksheetFunction.CountA(Range("A:A")) + 1
Cells(NextRow, 1) = tbDate.Value
Cells(NextRow, 2) = cmbEmployeeName.Value
Cells(NextRow, 3) = Application.WorksheetFunction.VLookup(cmbEmployeeName.Value, EESheet.Range("A:B"), 2, False)
Cells(NextRow, 4) = tbJobNumber.Value
Cells(NextRow, 5) = Me.Controls("tbJobExtra" & i).Value
Cells(NextRow, 6) = Me.Controls("cmbCC" & i).Value
Cells(NextRow, 7) = Application.WorksheetFunction.VLookup(cmbEmployeeName.Value, EESheet.Range("A:C"), 3, False)
Cells(NextRow, 8) = Application.WorksheetFunction.VLookup(cmbEmployeeName.Value, EESheet.Range("A:D"), 4, False)
Cells(NextRow, 9) = "OVT"
Cells(NextRow, 10) = Me.Controls("tbCC" & i & "OTHrs").Value
End If
If i + 1 = 7 Then Exit For
If Me.Controls("cmbCC" & i + 1).Value = "" Then Exit For
Next
Bad:
If Err.Number = 1004 Then
MsgBox "This EE Does Not Exist or You Typed Their Name Incorrectly. Check the EE name spelling or enter the EE into the Employees Tab."
NextRow = Application.WorksheetFunction.CountA(Range("A:A"))
Rows(NextRow).Delete
EEpayrollentry.Hide
Sheets("Employees").Activate
End If
i = 1
For i = 1 To 6
cmbEmployeeName.Value = ""
Me.Controls("tbJobExtra" & i).Text = ""
Me.Controls("cmbCC" & i).Text = ""
Me.Controls("tbCC" & i & "RegHrs").Text = ""
Me.Controls("tbCC" & i & "OTHrs").Text = ""
Next
EEpayrollentry.lbTotalHours.Caption = 0
End Sub

How to manipulate ReDim preserve multidimensional array ID's?

I have an issue that, multi dimensional array which is trying to put the ID's for group member combinations from calendar hierarchy (Year -> super_Season -> Quarter -> month -> week). problem is one of the Week's ID number to be changed when it comes to the particular week. Say for example as per the screenshot if this week comes the ID/index should get increased by 1
Entry which needs to change the ID
The code which i have to modify for this issue is as below
Public Function writeStructure(intdimension As Integer) As Boolean
Dim objGroup As Variant
Dim objMember As Variant
Dim strError As String
Dim i As Integer
Dim j As Integer
On Error GoTo ErrorRoutine
writeStructure = False
'write structure
strError = "writing structure to " & readIniFileString("Dimensions", "Name" & intdimension, strControlFileIni)
With Worksheets(readIniFileString("Dimensions", "Name" & intdimension, strControlFileIni))
.Cells.Clear
i = 1
For Each objGroup In objGroups.Items
.Cells(i, 1).Value = objGroup.Number
.Cells(i, 2).Value = objGroup.Name
i = i + 1
Next
i = 1
For Each objMember In objMembers.Items
.Cells(i, 3).Value = objMember.Number
.Cells(i, 4).Value = objMember.Name
.Cells(i, 5).Value = objMember.Description
.Cells(i, 6).Value = objMember.Group
.Cells(i, 7).Value = objMember.groupName
For j = 1 To objMember.countOfParents
.Cells(i, 7 + j).Value = objMember.Parent(j) ' ID values are assigning
Next j
i = i + 1
Next
End With

vba code not taking correct value of a cell from file

This is my code:
Dim RowLast As Long
Dim sunmLast As Long
Dim tempLast As Long
Dim filterCriteria As String
Dim perporig As Workbook
Dim x As String
tempLast = ThisWorkbook.Sheets("combine BOMs").Cells(Rows.Count, "E").End(xlUp).Row
Range("D5:G" & tempLast).ClearContents
Range("G5:G" & tempLast).Interior.ColorIndex = 0
tempLast = ThisWorkbook.Sheets("combine BOMs").Cells(Rows.Count, "A").End(xlUp).Row
Range("A5:A" & tempLast).ClearContents
tempLast = ThisWorkbook.Sheets("combine BOMs").Cells(Rows.Count, "B").End(xlUp).Row
'Perpetual
Set perporig = Workbooks.Open("\\Etnfps02\vol1\DATA\Inventory\Daily tracking\perpetual.xlsx", UpdateLinks:=False, ReadOnly:=True)
RowLast = perporig.Sheets("perpetual").Cells(Rows.Count, "A").End(xlUp).Row
perporig.Sheets("perpetual").Cells(3, 1) = "Part Number"
For i = 5 To tempLast
Cells(i, 1) = i - 4
perporig.Sheets("perpetual").AutoFilterMode = False
filterCriteria = ThisWorkbook.Sheets("combine BOMs").Range("B" & i).Value
perporig.Sheets("perpetual").Range("A3:J" & RowLast).AutoFilter Field:=1, Criteria1:=filterCriteria
Counter = perporig.Sheets("perpetual").Cells(RowLast + 1, 1).End(xlUp).Row
If Counter = 3 Then
Cells(i, 5).Value = "Not on perpetual"
Else
ThisWorkbook.Sheets("combine BOMs").Cells(i, 5).Value = WorksheetFunction.Sum(perporig.Sheets("perpetual").Range("H4:H" & RowLast).SpecialCells(xlCellTypeVisible))
x = perporig.Sheets("perpetual").Cells(Cells(RowLast + 1, 1).End(xlUp).Row, 4).Value
MsgBox x, vbOKOnly, perporig.Sheets("perpetual").Cells(RowLast + 1, 1).End(xlUp).Row
ThisWorkbook.Sheets("combine BOMs").Cells(i, 4).Value = x
End If
perporig.Sheets("perpetual").AutoFilterMode = False
Next
perporig.Close savechanges:=False
This is the file from which I am clicking my button (or ThisWorkbook)
This is the perpetual file when it is running on the last row of data:
Notice the difference in D9280: it shows stocking type as "P" in the perpetual file, but "B" in my final result, which comes up in cell D12 in ThisWorkbook. To debug, I created a Msgbox prompt for everytime it gets that value for all rows. For every other row, it gives the correct value ("P"), but for this one, msgbox shows "B". The title of the msgbox is the row number, which shows it is taking the correct row whilr getting the value, just that I don't know why it is taking wrong value. I have tried for different data sources, it seems to be coming up with "B" in wrong places every so often.
In the code, just above the line, I have the line to get the on hand quantity, which it does take correctly (I used xltypevisible to paste values for this field, but that is only because I wanted a sum of the results and this was the only way I knew). It's only this stocking type column which shows wrong values randomly.
Any ideas?
Thanks!
1)
Cells(i, 1) = i - 4
as it is written , it refers to perporig.Cells(i, 1)
is this what you want?
2)
perporig.Sheets("perpetual").Range("A3:J" & RowLast).AutoFilter Field:=1, Criteria1:=filterCriteria
would filter from row 3, while you have headers in row 4 and data from row 5 downwards
change it to
perporig.Sheets("perpetual").Range("A4:J" & RowLast).AutoFilter Field:=1, Criteria1:=filterCriteria
3)
what do you think is Counter doing? Not certainly count visible rows only
Credits to findwindow, I found the answer. The .cells(cells()) part didn't have the correct sheet reference for the inner cells():
Instead of
x = perporig.Sheets("perpetual").Cells(Cells(RowLast + 1, 1).End(xlUp).Row, 4).Value
MsgBox x, vbOKOnly, perporig.Sheets("perpetual").Cells(RowLast + 1, 1).End(xlUp).Row
I used this:
With perporig.Sheets("perpetual")
x = .Cells(.Cells(RowLast + 1, 1).End(xlUp).Row, 4).Value
MsgBox x, vbOKOnly, .Cells(RowLast + 1, 1).End(xlUp).Row
End With
And it worked.
Thanks for your help!

Listbox update sequence incorrect

I'm building a weekly time-sheet tracking database. The input form contains 2 list boxes. "ListBox1" and "ListBox2" . ListBox1 allows the user to select a specific project, once a project is selected - various text boxes are populated with information. The user can then input their daily hours worked. When the user clicks a submit button the code verify's if there is a worksheet allocated for the selected project - if yes - it will load the inputted data into the sheet, if no it will create a new sheet. Once data is entered it will calculate and autosend a notification email if certain criteria are met.
At this point - ListBox 2 updates with the contents of all the inputted entries for that given project worksheet when the "Submit" button is clicked.
I would rather for ListBox 2 to update as the user selects the project from ListBox 1. I've tried moving the related code to the Listbox1_Click() routine but to no avail.
I'm very new to this so any suggestions would be greatly appreciated.
Working code as it currently stands.
Private Sub CommandButton1_Click()
'activateSheet(Weeklyhours As String)
'Sheets(Weeklyhours).Select
'ActiveSheet.Range("I2").Select = TxtMonhours.Text
'ActiveSheet.Range("j2").Select = TxtTueshours.Text
Dim Total As Double
Dim i As Integer
Dim PO As String
Dim CoRequest As Integer
'Make sure correct worksheet is selected to store data
'Application.Workbooks("TestDataBase.xlsx")
'Add a sheet for the PO Number
PO_Sheet_Name = txtPO.Text
CoRequest = txtPOhours.Value * 0.2
MsgBox "Safety hours level = " & CoRequest
Safetyhrs.Text = "FYI - Hours Warnings will commence below " & CoRequest & " hours."
'Check to see if a sheet already exists
For rep = 1 To (Worksheets.Count)
If LCase(Sheets(rep).Name) = LCase(PO_Sheet_Name) Then 'If a sheet exists activate it and confirm hours are available
Sheets(PO_Sheet_Name).Activate
'Confirm hours left.
MsgBox "Hrs available = " & txthrsavail.Value
If txthrsavail.Value <> "0" Or txthrsavail.Value < "0" Then
'Find last row
LastRow = Worksheets(PO_Sheet_Name).Cells(65000, 9).End(xlUp).Row
FirstRow = Worksheets(PO_Sheet_Name).Cells(2, 9).Row
i = LastRow + 1
'MsgBox LastRow
Cells(LastRow + 1, 8).Value = txtPO.Text
Cells(LastRow + 1, 9).Value = txtweek.Text
Cells(LastRow + 1, 10).Value = TxtMonhours.Text
Cells(LastRow + 1, 11).Value = TxtTuehours.Text
Cells(LastRow + 1, 12).Value = TxtWedhours.Text
Cells(LastRow + 1, 13).Value = TxtThurhours.Text
Cells(LastRow + 1, 14).Value = Txtfrihours.Text
Cells(LastRow + 1, 15).Value = txtSathrs.Text
Cells(LastRow + 1, 16).Value = txtSunhrs.Text
'Add total hours for week
Cells(LastRow + 1, 18).Activate
ActiveCell.FormulaR1C1 = "=SUM(RC[-8]:RC[-2])"
'Calculate total hours todate
Total = Application.sum(Sheets(PO_Sheet_Name).Range("r3:r" & i))
MsgBox "Total hours consumed = " & Total & "Hrs."
txtweektotal.Text = Cells(LastRow + 1, 18)
txthoursused.Text = Total
txthrsavail.Text = txtPOhours.Value - Total
Cells(LastRow + 1, 20).Value = txthrsavail.Text
' Upade table
With Me.ListBox2
.ColumnCount = 14
.ColumnWidths = "70;55;55;55;55;55;55;55;55;20;45;10;55;55"
.RowSource = Sheets(PO_Sheet_Name).Range("h2:t" & i).Address
End With
'Issue Status Check
If txthrsavail.Value < CoRequest And txthrsavail.Value > "0" Or txthrsavail.Value = CoRequest And txthrsavail.Value > "0" Then
MsgBox "There are only " & txthrsavail.Value & " hours remaining plesase notify your supervisor"
Call Mail_ActiveSheet
ElseIf txthrsavail.Value = "0" Or txthrsavail.Value < "0" Then
MsgBox "No Hours are available on this PO - please speak to your manager and stop all work", vbCritical
End If
End If
Exit Sub
End If
Next 'If no sheet exists - create a sheet that matches the PO number
Sheets.Add After:=Sheets(Sheets.Count)
Sheets(ActiveSheet.Name).Name = PO_Sheet_Name
MsgBox "Creating PO Sheet as it does not Exist"
'Enter Header Lines for spreadsheet
Range("H2").Select
ActiveCell.FormulaR1C1 = "PO Number"
Range("I2").Select
ActiveCell.FormulaR1C1 = "Weekend"
Range("J2").Select
ActiveCell.FormulaR1C1 = "Monday"
Range("K2").Select
ActiveCell.FormulaR1C1 = "Tuesday "
Range("L2").Select
ActiveCell.FormulaR1C1 = "Wednesday "
Range("M2").Select
ActiveCell.FormulaR1C1 = "Thursday "
Range("N2").Select
ActiveCell.FormulaR1C1 = "Friday"
Range("O2").Select
ActiveCell.FormulaR1C1 = "Sathurday "
Range("P2").Select
ActiveCell.FormulaR1C1 = "Sunday"
Range("R2").Select
ActiveCell.FormulaR1C1 = "Total"
Range("T2").Select
ActiveCell.FormulaR1C1 = "Hours Remaining"
'Enter Data
'Find last row
LastRow = Worksheets(PO_Sheet_Name).Cells(65000, 9).End(xlUp).Row
FirstRow = Worksheets(PO_Sheet_Name).Cells(2, 9).Row
i = LastRow + 1
'MsgBox LastRow
'Enter data to rows
Cells(LastRow + 1, 8).Value = txtPO.Text
Cells(LastRow + 1, 9).Value = txtweek.Text
Cells(LastRow + 1, 10).Value = TxtMonhours.Text
Cells(LastRow + 1, 11).Value = TxtTuehours.Text
Cells(LastRow + 1, 12).Value = TxtWedhours.Text
Cells(LastRow + 1, 13).Value = TxtThurhours.Text
Cells(LastRow + 1, 14).Value = Txtfrihours.Text
Cells(LastRow + 1, 15).Value = txtSathrs.Text
Cells(LastRow + 1, 16).Value = txtSunhrs.Text
' 'Add total hours for week
Cells(LastRow + 1, 18).Activate
ActiveCell.FormulaR1C1 = "=SUM(RC[-8]:RC[-2])"
'Calculate total hours todate
Total = Application.sum(Sheets(PO_Sheet_Name).Range("r3:r" & i))
txtweektotal.Text = Cells(LastRow + 1, 18)
txthoursused.Text = Total
txthrsavail.Text = txtPOhours.Value - Total
Cells(LastRow + 1, 20).Value = txthrsavail.Text
'issue status check
If txthrsavail.Value < CoRequest And txthrsavail.Value > "0" Then
MsgBox "There are only " & txthrsavail.Value & "available plesase notify your supervisor"
'send mail update
Call Mail_ActiveSheet
ElseIf txthrsavail.Value = "0" Or txthrsavail.Value < "0" Then
MsgBox "You have no hours left on PO - Please contact your manager and stop all work", vbCritical
End If
'Load history
With Me.ListBox2
.ColumnCount = 14
.ColumnWidths = "70;55;55;55;55;55;55;55;55;20;45;10;55;55"
.RowSource = Sheets(PO_Sheet_Name).Range("h2:t" & i).Address
End With
ActiveWorkbook.Save
End Sub
ListBox1 Code as it currently stands. [ I've commented out where I was placing Me.ListBox2 command as it won't run correctly.]
Private Sub ListBox1_Click()
Dim Total As Long
Dim i As Integer
Dim PO As String
Dim CoRequest As Integer
PO_Sheet_Name = txtPO.Text
Sheets("Projects Sheet").Range("k3").Value = ListBox1.Value
txtsponsor.Text = Sheets("Projects Sheet").Range("L3")
txtPOhours.Text = Sheets("Projects Sheet").Range("M3")
txtPO.Text = Sheets("Projects Sheet").Range("N3")
'Find last row
' LastRow = Worksheets(PO_Sheet_Name).Cells(65000, 9).End(xlUp).Row
'FirstRow = Worksheets(PO_Sheet_Name).Cells(2, 9).Row
' i = LastRow + 1
' With Me.ListBox2
' .ColumnCount = 14
' .ColumnWidths = "70;55;55;55;55;55;55;55;55;20;45;10;55;55"
' .RowSource = Sheets(PO_Sheet_Name).Range("h2:r" & i).Address
' End With
You should use ListBox1_Change or ListBox1_BeforeUpdate
Here is a screenshot of MicroSoft VBA, you can use the two dropdown lists on top to select an object and an associated event :
and yet the Private Sub ListBox1_Click() is existing so I don't know what was your problem with

How to check for different worksheet names in excel and add new in case it doesn't exist

I'm exporting my data from MS Project to MS Excel (single pre-defined file with a given name all the time, for e.g. XYZ.xlsx) and want to have different worksheet in the excel for every workstream in the project. And number of workstreams can increase in future, thus I've to keep it dynamic.
As of now my code does the export, but I also want it to check if the workstream already exists,
- if yes, delete all the data in that worksheet and paste the new data in XYZ file.
- if no, create a new worksheet in the XYZ file and paste the data into it.
Can anyone please help as I'm on a deadline to finish it.
Code that I'm using it,
Set tsks = ThisProject.Tasks
For Each t In tsks
If Not t Is Nothing Then
If t.OutlineLevel > 1 Then
If t.OutlineLevel = 2 Then
If ExcelRowCounter > 2 Then
'Finish formatting the sheet we just finished
For i = 1 To 7
xlSheet.Columns(i).AutoFit
Next i
End If
'Add Excel sheet, name it and define column headers
AppActivate ExcelAppTitle
Set xlSheet = xlBook.Worksheets.Add
ExcelSheetName = Left(Replace(t.Name, "&", "and"), 30)
xlSheet.Name = ExcelSheetName
xlSheet.Cells(1, 1).Value = "Task Name"
xlSheet.Cells(1, 2).Value = "Duration (days)"
xlSheet.Cells(1, 3).Value = "Start Date"
xlSheet.Cells(1, 4).Value = "Finish Date"
xlSheet.Cells(1, 5).Value = "Workstream Group"
xlSheet.Cells(1, 6).Value = "% Complete"
xlSheet.Cells(1, 7).Value = "Status"
xlSheet.Range(xlSheet.Cells(1, 1), xlSheet.Cells(1, 7)).Font.Bold = True
ExcelRowCounter = 2
End If
xlSheet.Cells(ExcelRowCounter, 1).Value = t.Name
xlSheet.Cells(ExcelRowCounter, 2).Value = t.Duration / (8 * 60)
xlSheet.Cells(ExcelRowCounter, 3).Value = Format(t.Start, "mm/dd/yyyy")
xlSheet.Cells(ExcelRowCounter, 4).Value = Format(t.Finish, "mm/dd/yyyy")
xlSheet.Cells(ExcelRowCounter, 5).Value = t.Text1
xlSheet.Cells(ExcelRowCounter, 6).Value = t.PercentComplete
xlSheet.Cells(ExcelRowCounter, 7).Value = t.Number1
xlSheet.Cells(ExcelRowCounter, 1).IndentLevel = 2 * (t.OutlineLevel - 2)
If t.Summary = "True" Then
xlSheet.Range(xlSheet.Cells(ExcelRowCounter, 1), xlSheet.Cells(ExcelRowCounter, 6)).Font.Bold = True
End If
ExcelRowCounter = ExcelRowCounter + 1
End If
End If
Next t
For i = 1 To 7
xlSheet.Columns(i).AutoFit
Next i
Here's as simple method:
Function AddOrGetWorksheet(withName As String) As Worksheet
Dim found As Boolean
found = False
Dim ws As Worksheet
For Each ws In ActiveWorkbook.Sheets
If (LCase(ws.Name) = LCase(withName)) Then
found = True
Set AddOrGetWorksheet = ws
Exit For
End If
Next
If (Not found) Then
Set AddOrGetWorksheet = ActiveWorkbook.Sheets.Add()
AddOrGetWorksheet.Name = withName
End If
End Function