I wrote some codes for the data validation column to automatically generate cells and it was seemed to be worked in the first time, but after i closed file and open again, it didn't work.
Thank you help
Private Sub Worksheet_Change(ByVal Target As Range)
On Error GoTo ErrHandler
Application.EnableEvents = False
Dim catCode As String
If Target.Cells.Count <> 1 Then Exit Sub
If Target.Column = 2 Then
catCode = Target.Value
Select Case catCode
Case "AUTOMATIC LEVEL", "DIGITAL LEVEL"
Target.Offset(0, 7) = "19/99"
Target.Offset(0, 8) = 1
Case "BAROMETER", "THERMOMETER"
Target.Offset(0, 7) = "24/99"
Target.Offset(0, 8) = 1
Case "BRACKET BUBBLE"
Target.Offset(0, 7) = "23/99"
Target.Offset(0, 8) = 0.5
Case "CARPENTER LEVEL", "REFLECTOR POLE"
Target.Offset(0, 7) = "23/99"
Target.Offset(0, 8) = 0.5
Case "CLINOMETER", "TRIBRACH"
Target.Offset(0, 7) = "23/99"
Target.Offset(0, 8) = 1
Case "DIPMETER"
Target.Offset(0, 7) = "18/99"
Target.Offset(0, 8) = 1
Case "DIGITAL MEASURING POLE"
Target.Offset(0, 7) = "18/99"
Target.Offset(0, 8) = 1
Case "FIBRE GLASS / LENEN TAPE"
Target.Offset(0, 7) = "18/99"
Target.Offset(0, 8) = 1
Case "STEEL POCKET MEASURING TAPE"
Target.Offset(0, 7) = "18/99"
Target.Offset(0, 8) = 1
Case "STEEL TAPE", "STEEL RULER", "STILON TAPE"
Target.Offset(0, 7) = "18/99"
Target.Offset(0, 8) = 1
Case "DISTOMETER"
Target.Offset(0, 7) = "27/99"
Target.Offset(0, 8) = 2
Case "GPS"
Target.Offset(0, 7) = "21/99"
Target.Offset(0, 8) = 1
Case "HAND HELD LASER METER", "TOTAL STATION", "TOTAL STATION WITH REFLECTORLESS"
Target.Offset(0, 7) = "20/99"
Target.Offset(0, 8) = 1
Case "LEVELLING STAFF - TELESCOPIC", "LEVELLING STAFF - NON BARCODE", "LEVELLING STAFF"
Target.Offset(0, 7) = "22/99"
Target.Offset(0, 8) = 1
Case "MEASURING WHEEL"
Target.Offset(0, 7) = "3/00"
Target.Offset(0, 8) = 1
Case "PLANIMETER"
Target.Offset(0, 7) = "26/99"
Target.Offset(0, 8) = 1
Case "PLOTTER"
Target.Offset(0, 7) = "28/99"
Target.Offset(0, 8) = 1
Case "SPRING BALANCE"
Target.Offset(0, 7) = "24/99"
Target.Offset(0, 8) = 2
Case "EDM", "THEODOLITE"
Target.Offset(0, 7) = "N/A"
Target.Offset(0, 8) = 1
End Select
Else
Exit Sub
End If
ErrHandler:
Application.EnableEvents = True
End Sub
Moving the Application.EnableEvents = False inside the If Target.Column = 2 block will prevent your code from exiting without resetting the Application.EnableEvents flag. Managing the Application.EnableEvents flag can become a problem as your code changes in the future (especially when using Exit Sub statements). Another approach that avoids this problem is to handle the Application.EnableEvents flag management separately from your behavior logic...something like.
Private Sub Worksheet_Change(ByVal Target As Range)
Application.EnableEvents = False
On Error Resume Next
LoadCells Target
Application.EnableEvents = True
End Sub
Private Sub LoadCells(ByVal Target As Range)
Dim catCode As String
If Target.Cells.Count <> 1 Then Exit Sub
If Target.Column = 2 Then
catCode = Target.Value
Select Case catCode
Case "AUTOMATIC LEVEL", "DIGITAL LEVEL"
Target.Offset(0, 7) = "19/99"
Target.Offset(0, 8) = 1
Case "BAROMETER", "THERMOMETER"
Target.Offset(0, 7) = "24/99"
Target.Offset(0, 8) = 1
Case "BRACKET BUBBLE"
Target.Offset(0, 7) = "23/99"
Target.Offset(0, 8) = 0.5
Case "CARPENTER LEVEL", "REFLECTOR POLE"
Target.Offset(0, 7) = "23/99"
Target.Offset(0, 8) = 0.5
Case "CLINOMETER", "TRIBRACH"
Target.Offset(0, 7) = "23/99"
Target.Offset(0, 8) = 1
Case "DIPMETER"
Target.Offset(0, 7) = "18/99"
Target.Offset(0, 8) = 1
Case "DIGITAL MEASURING POLE"
Target.Offset(0, 7) = "18/99"
Target.Offset(0, 8) = 1
Case "FIBRE GLASS / LENEN TAPE"
Target.Offset(0, 7) = "18/99"
Target.Offset(0, 8) = 1
Case "STEEL POCKET MEASURING TAPE"
Target.Offset(0, 7) = "18/99"
Target.Offset(0, 8) = 1
Case "STEEL TAPE", "STEEL RULER", "STILON TAPE"
Target.Offset(0, 7) = "18/99"
Target.Offset(0, 8) = 1
Case "DISTOMETER"
Target.Offset(0, 7) = "27/99"
Target.Offset(0, 8) = 2
Case "GPS"
Target.Offset(0, 7) = "21/99"
Target.Offset(0, 8) = 1
Case "HAND HELD LASER METER", "TOTAL STATION", "TOTAL STATION WITH REFLECTORLESS"
Target.Offset(0, 7) = "20/99"
Target.Offset(0, 8) = 1
Case "LEVELLING STAFF - TELESCOPIC", "LEVELLING STAFF - NON BARCODE", "LEVELLING STAFF"
Target.Offset(0, 7) = "22/99"
Target.Offset(0, 8) = 1
Case "MEASURING WHEEL"
Target.Offset(0, 7) = "3/00"
Target.Offset(0, 8) = 1
Case "PLANIMETER"
Target.Offset(0, 7) = "26/99"
Target.Offset(0, 8) = 1
Case "PLOTTER"
Target.Offset(0, 7) = "28/99"
Target.Offset(0, 8) = 1
Case "SPRING BALANCE"
Target.Offset(0, 7) = "24/99"
Target.Offset(0, 8) = 2
Case "EDM", "THEODOLITE"
Target.Offset(0, 7) = "N/A"
Target.Offset(0, 8) = 1
End Select
Else
Exit Sub
End If
End Sub
Related
I have this simple bit of code that automates some dates and stuff when adding line items to a sheet. It works well, but when I insert a line in to the spreadsheet [right-click the line name > insert] an error occurs.
Private Sub Worksheet_Change(ByVal Target As Range)
Dim cell As Range
Dim plusWeek
plusWeek = Now() + 7
For Each cell In Target
'========adds closed date, deleted date if status degenerates=========
If cell.Column = 13 And cell = "Closed" Then
Target.Offset(0, -2) = Format(Now(), "yyyy-mm-dd")
End If
If cell.Column = 13 And cell = "In-Progress" Then
Target.Offset(0, -2) = ""
End If
If cell.Column = 13 And cell = "Open" Then
Target.Offset(0, -2) = ""
End If
'========adds date added if date is embty and description is not empty========
If cell.Column = 8 And IsEmpty(Target.Offset(0, 1)) And Not IsEmpty(Target.Offset(0, 0)) Then
Target.Offset(0, 1) = Format(Now(), "yyyy-mm-dd")
Target.Offset(0, 2) = Format(plusWeek, "yyyy-mm-dd")
Target.Offset(0, 5) = "Open"
End If
'========deletes date added if description is empty========
'If cell.Column = 8 And IsEmpty(Target.Offset(0, 0)) Then
' Target.Offset(0, 1) = ""
'End If
Next cell
End Sub
if I paste a line, add a line or delete a line, error 1004 occurs. The debugger highlights this line, but I can't understand where the error comes from.
If cell.Column = 8 And IsEmpty(Target.Offset(0, 1)) And Not
IsEmpty(Target.Offset(0, 0)) Then
Something like this should work:
Private Sub Worksheet_Change(ByVal Target As Range)
Dim cell As Range, rng As Range
Dim plusWeek
plusWeek = Now() + 7
Set rng = Application.Intersect(Target, Me.Range("H:H,M:M"))
If rng Is Nothing Then Exit Sub
On Error GoTo haveError '<< make sure events don't get left turned off
Application.EnableEvents = False '<< turn events off
For Each cell In rng.Cells
'========adds closed date, deleted date if status degenerates=========
If cell.Column = 13 Then
Select Case cell.Value
Case "Closed": cell.Offset(0, -2) = Format(Now(), "yyyy-mm-dd")
Case "In-Progress", "Open": cell.Offset(0, -2) = ""
End Select
End If
'========adds date added if date is embty and description is not empty========
If cell.Column = 8 And IsEmpty(cell.Offset(0, 1)) And Not IsEmpty(cell) Then
cell.Offset(0, 1) = Format(Now(), "yyyy-mm-dd")
cell.Offset(0, 2) = Format(plusWeek, "yyyy-mm-dd")
cell.Offset(0, 5) = "Open"
End If
'========deletes date added if description is empty========
'If cell.Column = 8 And IsEmpty(Target.Offset(0, 0)) Then
' Target.Offset(0, 1) = ""
'End If
Next cell
haveError:
Application.EnableEvents = True
End Sub
Hi I am having a excel file. There is a macro in the excel file to clear the dependent drop down list . When we copy the value from one row to another row or one column to another column we are getting run time error 13. Could you please help us to resolve the issue
Code :
Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Row > 2 And Target.Row < 100 Then
If Target.Column = 2 And Target.Cells.Count = 1 And Target.Value = "Create Account_Personal" Then
Target.Offset(0, 3).Value = "NA"
Target.Offset(0, 4).Value = "NA"
Target.Offset(0, 5).Value = "NA"
Target.Offset(0, 6).Value = "NA"
Target.Offset(0, 7).Value = "NA"
Target.Offset(0, 8).Value = "NA"
Target.Offset(0, 9).Value = "NA"
Target.Offset(0, 10).Value = "NA"
Target.Offset(0, 11).Value = "NA"
Target.Offset(0, 19).Value = "NO"
Target.Offset(0, 22).Value = "NO THANKS"
ElseIf Target.Column = 2 And Target.Cells.Count = 1 And Target.Value <> "Create Account_Personal" Then
Target.Offset(0, 3).Value = "Select Country"
End If
If Target.Column = 5 And Target.Cells.Count = 1 And Target.Value <> "NA" Then
Target.Offset(0, 1).Value = "select State"
Target.Offset(0, 2).Value = ""
Target.Offset(0, 3).Value = ""
Target.Offset(0, 4).Value = ""
Target.Offset(0, 5).Value = ""
Target.Offset(0, 6).Value = ""
Target.Offset(0, 7).Value = ""
Target.Offset(0, 9).Value = ""
Target.Offset(0, 10).Value = ""
Target.Offset(0, 11).Value = ""
Target.Offset(0, 12).Value = ""
Target.Offset(0, 13).Value = ""
Target.Offset(0, 14).Value = ""
Target.Offset(0, 15).Value = ""
End If
End If
End Sub`enter code here`
Disable events by using Application.EnableEvents = False
For consecutive cells use …
Target.Parent.Range(Target.Offset(0, 3), Target.Offset(0, 11)).Value = "NA"
… to write NA between column 3 and 11. Which is much shorter and faster.
Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
Application.EnableEvents = False
On Error GoTo ENABLE_EVENTS
If Target.Row > 2 And Target.Row < 100 Then
If Target.Column = 2 And Target.Cells.Count = 1 Then
If Target.Value = "Create Account_Personal" Then
Target.Parent.Range(Target.Offset(0, 3), Target.Offset(0, 11)).Value = "NA"
Target.Offset(0, 19).Value = "NO"
Target.Offset(0, 22).Value = "NO THANKS"
ElseIf Target.Value <> "Create Account_Personal" Then
Target.Offset(0, 3).Value = "Select Country"
End If
End If
If Target.Column = 5 And Target.Cells.Count = 1 Then
If Target.Value <> "NA" Then
Target.Offset(0, 1).Value = "select State"
Target.Parent.Range(Target.Offset(0, 2), Target.Offset(0, 7)).Value = ""
Target.Parent.Range(Target.Offset(0, 9), Target.Offset(0, 15)).Value = ""
End If
End If
End If
ENABLE_EVENTS:
Application.EnableEvents = True
If Err.Number <> 0 Then Err.Raise Err.Number, Err.Source, Err.Description, Err.HelpFile, Err.HelpContext
End Sub
I know that you can have only one private sub worksheet change event however I am struggling to combine code for the events I need. I am new to VBA so any assistance or recommendations are appreciated. Would it be more efficient to use select case?
First code needed:
Private Sub Worksheet_Change(ByVal target As Range)
Dim cell As Range
Set cell = Range("AK9:AR50")
Application.EnableEvents = False
If Not Application.Intersect(cell, target) Is Nothing Then
If target.Column = 37 Then
target.Offset(, 1).Value = target.Value / Range("V" & target.Row).Value
ElseIf target.Column = 38 Then
target.Offset(, -1).Value = WorksheetFunction.RoundUp((target.Value * Range("V" & target.Row).Value), -2)
End If
If target.Column = 39 Then
target.Offset(, 1).Value = target.Value / Range("V" & target.Row).Value
ElseIf target.Column = 40 Then
target.Offset(, -1).Value = WorksheetFunction.RoundUp((target.Value * Range("V" & target.Row).Value), -2)
End If
If target.Column = 41 Then
target.Offset(, 1).Value = WorksheetFunction.RoundUp((target.Value * Range("V" & target.Row).Value), -2)
ElseIf target.Column = 42 Then
target.Offset(, -1).Value = target.Value / Range("V" & target.Row).Value
End If
If target.Column = 43 Then
target.Offset(, 1).Value = target.Value / Range("V" & target.Row).Value
ElseIf target.Column = 44 Then
target.Offset(, -1).Value = WorksheetFunction.RoundUp((target.Value * Range("V" & target.Row).Value), -2)
End If
End If
Application.EnableEvents = True
End Sub
Second code needed:
Private Sub Worksheet_Change(ByVal Target As Range)
Dim controlRng, nRng As Range
Set controlRng = Range("AF9:AF1000")
Set nRng = Intersect(controlRng, Target)
If nRng Is Nothing Then Exit Sub
If Target.Value = "No Promotion" Then
Target.Offset(0, 1) = Range("M" & Target.Row).Value
ElseIf Target.Value = "Promotion" Then
Target.Offset(0, 1) = ""
ElseIf Target.Value = "Demotion" Then
Target.Offset(0, 1) = ""
ElseIf Target.Value = "Partner" Then
Target.Offset(0, 1) = ""
ElseIf Target.Value = "" Then
Target.Offset(0, 1) = ""
End If
End Sub
Select Case will certainly tidy up your code. You might also want to build in a check that Target is not more than a single cell.
Private Sub Worksheet_Change(ByVal Target As Range)
Dim cell As Range
Dim controlRng As Range, nRng As Range
Set cell = Range("AK9:AR50")
Set controlRng = Range("AF9:AF1000")
Set nRng = Intersect(controlRng, Target)
Application.EnableEvents = False
If Not Application.Intersect(cell, Target) Is Nothing Then
Select Case Target.Column
Case 37, 39, 41, 43
Target.Offset(, 1).Value = Target.Value / Range("V" & Target.Row).Value
Case 38, 40, 42, 44
Target.Offset(, -1).Value = WorksheetFunction.RoundUp((Target.Value * Range("V" & Target.Row).Value), -2)
End Select
End If
If Not nRng Is Nothing Then
Select Case Target.Value
Case "No Promotion"
Target.Offset(0, 1) = Range("M" & Target.Row).Value
Case "Promotion", "Demotion", "Partner", ""
Target.Offset(0, 1).ClearContents
End Select
End If
Application.EnableEvents = True
End Sub
I am writing a code for ping tester.
In sheet one it keeps on pinging devices continuously and displays the ping time in column B. When any device becomes unreachable it shows the last ping time and duration of unreachability in next column. But when that device becomes reachable it sends the duration of reachability (report) to next sheet and start showing that device reachable.
I want to open the report sheet while macro is running in sheet1.
If I'm using select (as in code) it forces me to sheet1 but without this if I open sheeet2 the pinging time started typing in sheet2.
Sub Do_ping()
With ActiveWorkbook.Worksheets(1)
Worksheets("sheet1").Select
row = 2
Do
If .Cells(row, 1) <> "" Then
If IsConnectible(.Cells(row, 1), 2, 100) = True Then
Worksheets("sheet1").Select
If Cells(row, 3).Value = nul Then
Cells(row, 1).Interior.Color = RGB(0, 255, 0)
Cells(row, 1).Font.FontStyle = "bold"
Cells(row, 1).Font.Size = 14
Cells(row, 2).Interior.Color = RGB(0, 255, 0)
Cells(row, 2).Value = Time
Else
Worksheets("sheet1").Select
Cells(row, 1).copy Sheets("sheet2").Range("A" & Rows.Count).End(xlUp).Offset(1, 0)
Cells(row, 2).copy Sheets("sheet2").Range("B" & Rows.Count).End(xlUp).Offset(1, 0)
Cells(row, 5).copy Sheets("sheet2").Range("c" & Rows.Count).End(xlUp).Offset(1, 0)
Cells(row, 1).Interior.Color = RGB(0, 255, 0)
Cells(row, 1).Font.FontStyle = "bold"
Cells(row, 1).Font.Size = 14
Cells(row, 2).Interior.Color = RGB(0, 255, 0)
Cells(row, 2).Value = Time
Cells(row, 5).ClearContents
End If
'Call siren
Else:
'Cells(Row, 2).Formula = "=NOW()-" & CDbl(Now())
'Cells(Row, 1).Interior.Color = RGB(255, 0, 0)
Worksheets("sheet1").Select
Cells(row, 3).Value = DateDiff("d", Cells(row, 2), Now())
'Time Difference. First set the format in cell.
Cells(row, 4).NumberFormat = "hh:mm:ss"
'/calculate and update
Cells(row, 4).Value2 = Now() - Cells(row, 2)
Cells(row, 5).Value = Hour(Cells(row, 4).Value2) * 3600 + Minute(Cells(row, 4).Value2) * 60 + Second(Cells(row, 4).Value2)
If Cells(row, 5).Value > 120 Then
Worksheets("sheet1").Select
Cells(row, 1).Interior.ColorIndex = 3
Cells(row, 2).Interior.ColorIndex = 3
Cells(row, 3).Interior.ColorIndex = 3
Cells(row, 4).Interior.ColorIndex = 3
Else
Worksheets("sheet1").Select
Cells(row, 1).Interior.ColorIndex = 40
Cells(row, 2).Interior.ColorIndex = 40
Cells(row, 3).Interior.ColorIndex = 40
Cells(row, 4).Interior.ColorIndex = 40
End If
End If
End If
row = row + 1
Loop Until .Cells(row, 1) = ""
End With
End Sub
You should get rid of Select in your code, and make better use of With blocks.
Assuming the first sheet in your workbook is "Sheet1", the following code is a refactored version of your code, getting rid of the Select statements.
Sub Do_ping()
With Worksheets("Sheet1")
row = 2
Do
If .Cells(row, 1) <> "" Then
If IsConnectible(.Cells(row, 1), 2, 100) = True Then
If .Cells(row, 3).Value = nul Then ' has the variable "nul" been defined?
.Cells(row, 1).Interior.Color = RGB(0, 255, 0)
.Cells(row, 1).Font.FontStyle = "bold"
.Cells(row, 1).Font.Size = 14
.Cells(row, 2).Interior.Color = RGB(0, 255, 0)
.Cells(row, 2).Value = Time
Else
.Cells(row, 1).copy Sheets("sheet2").Range("A" & Sheets("sheet2").Rows.Count).End(xlUp).Offset(1, 0)
.Cells(row, 2).copy Sheets("sheet2").Range("B" & Sheets("sheet2").Rows.Count).End(xlUp).Offset(1, 0)
.Cells(row, 5).copy Sheets("sheet2").Range("c" & Sheets("sheet2").Rows.Count).End(xlUp).Offset(1, 0)
.Cells(row, 1).Interior.Color = RGB(0, 255, 0)
.Cells(row, 1).Font.FontStyle = "bold"
.Cells(row, 1).Font.Size = 14
.Cells(row, 2).Interior.Color = RGB(0, 255, 0)
.Cells(row, 2).Value = Time
.Cells(row, 5).ClearContents
End If
'Call siren
Else
'Cells(Row, 2).Formula = "=NOW()-" & CDbl(Now())
'Cells(Row, 1).Interior.Color = RGB(255, 0, 0)
.Cells(row, 3).Value = DateDiff("d", .Cells(row, 2), Now())
'Time Difference. First set the format in cell.
.Cells(row, 4).NumberFormat = "hh:mm:ss"
'/calculate and update
.Cells(row, 4).Value2 = Now() - .Cells(row, 2)
.Cells(row, 5).Value = Hour(.Cells(row, 4).Value2) * 3600 + Minute(.Cells(row, 4).Value2) * 60 + Second(.Cells(row, 4).Value2)
If .Cells(row, 5).Value > 120 Then
.Cells(row, 1).Interior.ColorIndex = 3
.Cells(row, 2).Interior.ColorIndex = 3
.Cells(row, 3).Interior.ColorIndex = 3
.Cells(row, 4).Interior.ColorIndex = 3
Else
.Cells(row, 1).Interior.ColorIndex = 40
.Cells(row, 2).Interior.ColorIndex = 40
.Cells(row, 3).Interior.ColorIndex = 40
.Cells(row, 4).Interior.ColorIndex = 40
End If
End If
End If
row = row + 1
Loop Until .Cells(row, 1) = ""
End With
End Sub
Note: I would strongly recommend that you include Option Explicit as the first line of all your code modules - I suspect that your variable nul should be Null, and the use of Option Explicit would highlight that type of error.
I changed the code and its working
Sub Do_ping()
With Worksheets("Sheet1")
row = 2
Do
If .Cells(row, 1) <> "" Then
If IsConnectible(.Cells(row, 1), 2, 100) = True Then
'Worksheets("sheet1").Select
If Cells(row, 3).Value = nul Then
Sheets("sheet1").Cells(row, 1).Interior.Color = RGB(0, 255, 0)
Sheets("sheet1").Cells(row, 1).Font.FontStyle = "bold"
Sheets("sheet1").Cells(row, 1).Font.Size = 14
Sheets("sheet1").Cells(row, 2).Interior.Color = RGB(0, 255, 0)
Sheets("sheet1").Cells(row, 2).Value = Time
Else
'Worksheets("sheet1").Select
Sheets("sheet1").Cells(row, 1).copy Sheets("sheet2").Range("A" & Rows.Count).End(xlUp).Offset(1, 0)
Sheets("sheet1").Cells(row, 2).copy Sheets("sheet2").Range("B" & Rows.Count).End(xlUp).Offset(1, 0)
Sheets("sheet1").Cells(row, 5).copy Sheets("sheet2").Range("c" & Rows.Count).End(xlUp).Offset(1, 0)
Sheets("sheet1").Cells(row, 1).Interior.Color = RGB(0, 255, 0)
Sheets("sheet1").Cells(row, 1).Font.FontStyle = "bold"
Sheets("sheet1").Cells(row, 1).Font.Size = 14
Sheets("sheet1").Cells(row, 2).Interior.Color = RGB(0, 255, 0)
Sheets("sheet1").Cells(row, 2).Value = Time
Sheets("sheet1").Cells(row, 5).ClearContents
End If
'Call siren
Else:
'Cells(Row, 2).Formula = "=NOW()-" & CDbl(Now())
'Cells(Row, 1).Interior.Color = RGB(255, 0, 0)
'Worksheets("sheet1").Select
Sheets("sheet1").Cells(row, 3).Value = DateDiff("d", Cells(row, 2), Now())
'Time Difference. First set the format in cell.
Sheets("sheet1").Cells(row, 4).NumberFormat = "hh:mm:ss"
'/calculate and update
Sheets("sheet1").Cells(row, 4).Value2 = Now() - Cells(row, 2)
Sheets("sheet1").Cells(row, 5).Value = Hour(Cells(row, 4).Value2) * 3600 + Minute(Cells(row, 4).Value2) * 60 + Second(Cells(row, 4).Value2)
If Cells(row, 5).Value > 120 Then
'Worksheets("sheet1").Select
Sheets("sheet1").Cells(row, 1).Interior.ColorIndex = 3
Sheets("sheet1").Cells(row, 2).Interior.ColorIndex = 3
Sheets("sheet1").Cells(row, 3).Interior.ColorIndex = 3
Sheets("sheet1").Cells(row, 4).Interior.ColorIndex = 3
Else
'Worksheets("sheet1").Select
Sheets("sheet1").Cells(row, 1).Interior.ColorIndex = 40
Sheets("sheet1").Cells(row, 2).Interior.ColorIndex = 40
Sheets("sheet1").Cells(row, 3).Interior.ColorIndex = 40
Sheets("sheet1").Cells(row, 4).Interior.ColorIndex = 40
End If
End If
End If
row = row + 1
Loop Until .Cells(row, 1) = ""
End With
End Sub
Function IsConnectible(sHost, iPings, iTO)
' Returns True or False based on the output from ping.exe
' sHost is a hostname or IP
' iPings is number of ping attempts
' iTO is timeout in milliseconds
' if values are set to "", then defaults below used
Dim nRes
If iPings = "" Then iPings = 1 ' default number of pings
If iTO = "" Then iTO = 550 ' default timeout per ping
With CreateObject("WScript.Shell")
nRes = .Run("%comspec% /c ping.exe -n " & iPings & " -w " & iTO _
& " " & sHost & " | find ""TTL="" > nul 2>&1", 0, True)
End With
IsConnectible = (nRes = 0)
End Function
I take a project and export selected tasks into a Gantt chart in Excel.
The tasks that end up in the Excel chart are selected by highlighting them in Project and then running the macro. I would like for the macro to select these tasks by looking at the first and last task of that group. What I mean is I'd like to read the task names, find Task Name "A" and then process all the tasks afterwards until it hits Task Name "Z".
I tried to use the Task ID to set the ID numbers but the task number will change whenever new tasks are added to the project. I also tried using the unique ID but that won't work since there are some tasks between A and Z that have been in the project for a while so setting a specific range for that wouldn't work either.
I feel there is a simple way to do this but I just haven't stumbled upon it yet.
EDIT: Added the code below. The relevant section is just below the comment "Fill cells with Task information".
Sub ExportToExcel()
Dim xlApp As Excel.Application
Dim xlBook As Excel.Workbook
Dim xlSheet As Excel.Worksheet
Dim proj As Project
Dim t As Task
Dim pj As Project
Dim pjDuration As Integer
Dim i As Integer
Dim k As Integer
Dim c As Range
Set pj = ActiveProject
Set xlApp = New Excel.Application
'AppActivate "Excel"
xlApp.Visible = False
Set xlBook = xlApp.Workbooks.Open("C:\Users\Controls\Desktop\ServiceSchedule.xlsx")
xlApp.WindowState = xlMaximized
'Set up Project Detail Headers
Set xlSheet = xlBook.Worksheets(1)
xlSheet.Application.ScreenUpdating = False
xlSheet.Application.DisplayAlerts = False
xlSheet.UsedRange.Delete
xlSheet.Cells.Clear
xlSheet.Cells.ClearContents
'xlSheet.Cells(1, 1).Value = "Project Name"
'xlSheet.Cells(1, 2).Value = pj.Name
'xlSheet.Cells(2, 1).Value = "Project Title"
'xlSheet.Cells(2, 2).Value = pj.Title
'xlSheet.Cells(1, 4).Value = "Project Start"
'xlSheet.Cells(1, 5).Value = pj.ProjectStart
'xlSheet.Cells(2, 4).Value = "Project Finish"
'xlSheet.Cells(2, 5).Value = pj.ProjectFinish
'Set Gantt Chart Timespan
'xlSheet.Cells(1, 7).Value = "Project Duration"
pjDuration = 90
'xlSheet.Cells(1, 8).Value = pjDuration & "d"
'Set up Headers
xlSheet.Cells(4, 1).Value = "Task ID"
xlSheet.Cells(4, 2).Value = "Task Name"
xlSheet.Cells(4, 3).Value = "Name"
xlSheet.Cells(4, 4).Value = "Task Start"
xlSheet.Cells(4, 5).Value = "Task Finish"
xlSheet.Cells(4, 1).Font.Bold = True
xlSheet.Cells(4, 2).Font.Bold = True
xlSheet.Cells(4, 3).Font.Bold = True
xlSheet.Cells(4, 4).Font.Bold = True
xlSheet.Cells(4, 5).Font.Bold = True
'Freeze Rows & Columns
xlSheet.Range("F5").Select
xlSheet.Application.ActiveWindow.FreezePanes = True
'AutoFit Header columns and Hide blank rows
xlSheet.Columns("A:E").AutoFit
xlSheet.Columns("A").Hidden = True
xlSheet.Rows("1:2").Hidden = True
' Add day of the week headers for the entire Project's duration
For i = 0 To pjDuration
'If Today's Date is Sunday
If xlSheet.Application.WorksheetFunction.Weekday(Now()) = 1 Then
xlSheet.Cells(3, i + 6).Value = Now() + i
xlSheet.Cells(3, i + 6).NumberFormat = "[$-409]mmmm d, yyyy;#"
xlSheet.Cells(4, i + 6).Value = Now() + i
xlSheet.Cells(4, i + 6).NumberFormat = "ddd"
End If
'If Today's Date is Monday
If xlSheet.Application.WorksheetFunction.Weekday(Now()) = 2 Then
xlSheet.Cells(3, i + 6).Value = (Now() - 1) + i
xlSheet.Cells(3, i + 6).NumberFormat = "[$-409]mmmm d, yyyy;#"
xlSheet.Cells(4, i + 6).Value = (Now() - 1) + i
xlSheet.Cells(4, i + 6).NumberFormat = "ddd"
End If
'If Today's Date is Tuesday
If xlSheet.Application.WorksheetFunction.Weekday(Now()) = 3 Then
xlSheet.Cells(3, i + 6).Value = (Now() - 2) + i
xlSheet.Cells(3, i + 6).NumberFormat = "[$-409]mmmm d, yyyy;#"
xlSheet.Cells(4, i + 6).Value = (Now() - 2) + i
xlSheet.Cells(4, i + 6).NumberFormat = "ddd"
End If
'If Today's Date is Wednesday
If xlSheet.Application.WorksheetFunction.Weekday(Now()) = 4 Then
xlSheet.Cells(3, i + 6).Value = (Now() - 3) + i
xlSheet.Cells(3, i + 6).NumberFormat = "[$-409]mmmm d, yyyy;#"
xlSheet.Cells(4, i + 6).Value = (Now() - 3) + i
xlSheet.Cells(4, i + 6).NumberFormat = "ddd"
End If
'If Today's Date is Thursday
If xlSheet.Application.WorksheetFunction.Weekday(Now()) = 5 Then
xlSheet.Cells(3, i + 6).Value = (Now() - 4) + i
xlSheet.Cells(3, i + 6).NumberFormat = "[$-409]mmmm d, yyyy;#"
xlSheet.Cells(4, i + 6).Value = (Now() - 4) + i
xlSheet.Cells(4, i + 6).NumberFormat = "ddd"
End If
'If Today's Date is Friday
If xlSheet.Application.WorksheetFunction.Weekday(Now()) = 6 Then
xlSheet.Cells(3, i + 6).Value = (Now() - 5) + i
xlSheet.Cells(3, i + 6).NumberFormat = "[$-409]mmmm d, yyyy;#"
xlSheet.Cells(4, i + 6).Value = (Now() - 5) + i
xlSheet.Cells(4, i + 6).NumberFormat = "ddd"
End If
'If Today's Date is Saturday
If xlSheet.Application.WorksheetFunction.Weekday(Now()) = 7 Then
xlSheet.Cells(3, i + 6).Value = (Now() - 6) + i
xlSheet.Cells(3, i + 6).NumberFormat = "[$-409]mmmm d, yyyy;#"
xlSheet.Cells(4, i + 6).Value = (Now() - 6) + i
xlSheet.Cells(4, i + 6).NumberFormat = "ddd"
End If
'Color Weekend columns
xlSheet.Cells(4, i + 6).ColumnWidth = 10
If xlSheet.Application.Cells(4, i + 6).Text = "Sat" Then
For k = 1 To 100
xlSheet.Cells(4 + k, i + 6).Interior.ColorIndex = 15
Next
End If
If xlSheet.Application.Cells(4, i + 6).Text = "Sun" Then
For k = 1 To 100
xlSheet.Cells(4 + k, i + 6).Interior.ColorIndex = 15
Next
End If
Next
'Merge date cells
For i = 0 To pjDuration Step 7
xlSheet.Cells(3, i + 6).Select
xlSheet.Application.ActiveCell.Resize(1, 7).Select
With xlSheet.Application.Selection
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlBottom
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
xlSheet.Application.Selection.Merge
Next i
'Fill cells with Task information
Dim SearchString1 As String
Dim SearchString2 As String
SearchString1 = "Buyoffs/Service"
SearchString2 = "History"
**For Each t In ActiveSelection.Tasks
xlSheet.Cells(t.ID + 4, 1).Value = t.ID
xlSheet.Cells(t.ID + 4, 2).Value = t.Name
xlSheet.Cells(t.ID + 4, 3).Value = t.ResourceNames
xlSheet.Cells(t.ID + 4, 4).Value = t.Start
xlSheet.Cells(t.ID + 4, 4).NumberFormat = "[$-409]mm-dd-yy;#"
xlSheet.Cells(t.ID + 4, 5).Value = t.Finish
xlSheet.Cells(t.ID + 4, 5).NumberFormat = "[$-409]mm-dd-yy;#"**
'Loop to color cells to mimic Gantt chart
For i = 5 To pjDuration + 5
If t.Start <= xlSheet.Cells(4, i + 1) And t.Finish >= xlSheet.Cells(4, i + 1) Then
xlSheet.Cells(t.ID + 4, i + 1).Interior.ColorIndex = 37
With xlSheet.Cells(t.ID + 4, i + 1).Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.ThemeColor = 1
.TintAndShade = 0
.Weight = xlThin
End With
End If
Next i
Next t
'Loop To Change Day Headers to Single Char Format
For i = 0 To pjDuration
With xlSheet.Cells(4, i + 6)
If .Text = "Sun" Then
.Value = "S"
ElseIf .Text = "Mon" Then
.Value = "M"
ElseIf .Text = "Tue" Then
.Value = "T"
ElseIf .Text = "Wed" Then
.Value = "W"
ElseIf .Text = "Thu" Then
.Value = "R"
ElseIf .Text = "Fri" Then
.Value = "F"
ElseIf .Text = "Sat" Then
.Value = "S"
End If
End With
xlSheet.Cells(4, i + 6).ColumnWidth = 1.5
Next
'Remove empty rows
xlSheet.Range("A5:A10000").AutoFilter 1, "<>", , , False
'Autofit Columns
xlSheet.Columns("B:E").AutoFit
xlSheet.Columns("B:B").Select
With xlSheet.Application.Selection
.HorizontalAlignment = xlGeneral
.VerticalAlignment = xlBottom
.WrapText = True
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
xlSheet.Application.Selection.ColumnWidth = 50
With xlSheet.Application.Selection
.HorizontalAlignment = xlGeneral
.VerticalAlignment = xlBottom
.WrapText = True
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
'Format Cells with Borders
xlSheet.Rows("4:4").Select
xlSheet.Application.Selection.Borders(xlDiagonalDown).LineStyle = xlNone
xlSheet.Application.Selection.Borders(xlDiagonalUp).LineStyle = xlNone
xlSheet.Application.Selection.Borders(xlEdgeLeft).LineStyle = xlNone
xlSheet.Application.Selection.Borders(xlEdgeTop).LineStyle = xlNone
With xlSheet.Application.Selection.Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.ColorIndex = xlAutomatic
.TintAndShade = 0
.Weight = xlMedium
End With
xlSheet.Application.Selection.Borders(xlEdgeRight).LineStyle = xlNone
xlSheet.Application.Selection.Borders(xlInsideVertical).LineStyle = xlNone
xlSheet.Application.Selection.Borders(xlInsideHorizontal).LineStyle = xlNone
xlSheet.Columns("E:E").Select
xlSheet.Application.Selection.Borders(xlDiagonalDown).LineStyle = xlNone
xlSheet.Application.Selection.Borders(xlDiagonalUp).LineStyle = xlNone
xlSheet.Application.Selection.Borders(xlEdgeLeft).LineStyle = xlNone
xlSheet.Application.Selection.Borders(xlEdgeTop).LineStyle = xlNone
xlSheet.Application.Selection.Borders(xlEdgeBottom).LineStyle = xlNone
With xlSheet.Application.Selection.Borders(xlEdgeRight)
.LineStyle = xlContinuous
.ColorIndex = xlAutomatic
.TintAndShade = 0
.Weight = xlMedium
End With
xlSheet.Application.Selection.Borders(xlInsideVertical).LineStyle = xlNone
xlSheet.Range("F4:CR4").Select
With xlSheet.Application.Selection
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlBottom
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
xlSheet.Application.Selection.Borders(xlDiagonalDown).LineStyle = xlNone
xlSheet.Application.Selection.Borders(xlDiagonalUp).LineStyle = xlNone
With xlSheet.Application.Selection.Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.ColorIndex = xlAutomatic
.TintAndShade = 0
.Weight = xlMedium
End With
xlSheet.Application.Selection.Borders(xlEdgeTop).LineStyle = xlNone
With xlSheet.Application.Selection.Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.ColorIndex = xlAutomatic
.TintAndShade = 0
.Weight = xlMedium
End With
With xlSheet.Application.Selection.Borders(xlEdgeRight)
.LineStyle = xlContinuous
.ColorIndex = xlAutomatic
.TintAndShade = 0
.Weight = xlMedium
End With
With xlSheet.Application.Selection.Borders(xlInsideVertical)
.LineStyle = xlContinuous
.ColorIndex = xlAutomatic
.TintAndShade = 0
.Weight = xlMedium
End With
xlSheet.Application.Selection.Borders(xlInsideHorizontal).LineStyle = xlNone
xlApp.Visible = True
xlBook.Save
xlSheet.Application.DisplayAlerts = True
xlSheet.Application.ScreenUpdating = True
xlSheet.Application.ActiveWindow.Zoom = 100
End Sub
Okay I figured something out. Not the way I initially had in mind but it worked. I used the WBS property of Project to skip any task with outline level "1". So it would start at outline level "2" which contained what I wanted. Ending the loop was easy sine I just needed an If statement to jump out of the loop when it came across that last task name.
For Each t In ActiveProject.Tasks
If t.Name = "History" Then
Exit For
End If
If t.Name = "Vacations" Then
TaskA = t.ID
End If
If t.Name = "Buyoffs/Service" Then
TaskB = t.ID
End If
If t.Name = "Buyoffs/Service" Then GoTo NextIteration
TaskOffset = TaskB - TaskA + 1
If t.Name = "Vacations" Then GoTo NextIteration
If t.Name = "Unscheduled" Then GoTo NextIteration
If InStr(1, t.WBS, "1.") Then GoTo NextIteration
xlSheet.Cells(t.ID + 4 - TaskOffset, 1).Value = t.ID
xlSheet.Cells(t.ID + 4 - TaskOffset, 2).Value = t.Name
xlSheet.Cells(t.ID + 4 - TaskOffset, 3).Value = t.ResourceNames
xlSheet.Cells(t.ID + 4 - TaskOffset, 4).Value = t.Start
xlSheet.Cells(t.ID + 4 - TaskOffset, 4).NumberFormat = "[$-409]mm-dd-yy;#"
xlSheet.Cells(t.ID + 4 - TaskOffset, 5).Value = t.Finish
xlSheet.Cells(t.ID + 4 - TaskOffset, 5).NumberFormat = "[$-409]mm-dd-yy;#"