We all know we need to protect and secure our privileges, but where to start? Join Experts Exchange and ManageEngine on Tuesday, April 11, 2017 10:00 AM PDT to learn how to track and secure privileged users in Active Directory.
Sub Delete_rows()
With Application
.Calculation = xlCalculationManual
.ScreenUpdating = False
For i = Cells(Rows.Count, 1).End(xlUp).Row To 1 Step -1
If Left(Cells(i, 1), 6) = "Status" Or Left(Cells(i, 1), 5) = "WorkID" Or Left(Cells(i, 1), 7) = "P_Owners" Or Left(Cells(i, 1), 10) = "WorkStatus" Or Left(Cells(i, 1), 11) = "WorkIDs" Or Left(Cells(i, 1), 14) = "FunctionTitles" Or Left(Cells(i, 1), 19) = "FunctionIDAncestors" Or Left(Cells(i, 1), 10) = "DateCreate" Or Left(Cells(i, 1), 10) = "NameCreate" Or Left(Cells(i, 1), 12) = "DateLastEdit" Or Left(Cells(i, 1), 12) = "NameLastEdit" Or Left(Cells(i, 1), 9) = "$WebFlags" Or Left(Cells(i, 1), 15) = "$ConflictAction" Or Left(Cells(i, 1), 6) = "Phases" Or Left(Cells(i, 1), 7) = "Subform" Or Left(Cells(i, 1), 8) = "NumTests" Or Left(Cells(i, 1), 15) = "DescriptionText" Or Left(Cells(i, 1), 12) = "ExecCycleIDs" Or Left(Cells(i, 1), 15) = "ExecCycleTitles" Or Left(Cells(i, 1), 18) = "ExecAllCycleTitles" Or Left(Cells(i, 1), 15) = "ExecAllCycleIDs" Or Left(Cells(i, 1), 17) = "ExecAllResults_id" Or Left(Cells(i, 1), 15) = "ExecAllBuilds_id" Or Left(Cells(i, 1), 9) = "ExecAllid" Or Left(Cells(i, 1), 18) = "WorkExecA
llDefects" Or Left(Cells(i, 1), 15) = "WorkEventLog001" Or Left(Cells(i, 1), 14) = "Work_OldValues" Or Left(Cells(i, 1), 14) = "$WorkUpdatedBy" Or Left(Cells(i, 1), 14) = "$WorkRevisions" Then
Cells(i, 1).EntireRow.Delete
End If
Next i
.Calculation = xlCalculationAutomatic
.ScreenUpdating = True
End With
End Sub
Option Explicit
Sub Delete_rows()
Dim rng As Range
Dim arrTerms
Dim I As Long
Dim J As Long
arrTerms = Array("Status", "WorkID", "POwners", "WorkStatus", _
"WorkIDs", "FunctionTitles", "FunctionIDAncestors", _
"DateCreate", "NameCreate", "DateLastEdit", _
"NameLastEdit", "$WebFlags", "$ConflictAction", _
"Phases", "Subform", "NumTests", _
"DescriptionText", "ExecCycleIDs", "ExecCycleTitles", _
"ExecAllCycleTitles", "ExecAllCycleIDs", "ExecAllResultsid", _
"ExecAllBuildsid", "ExecAllid", "WorkExecAllDefects", _
"WorkEventLog001", "WorkOldValues", "$WorkUpdatedBy", "$WorkRevisions")
With Application
.Calculation = xlCalculationManual
.ScreenUpdating = False
For I = Cells(Rows.Count, 1).End(xlUp).Row To 1 Step -1
Set rng = Cells(I, 6)
For J = LBound(arrTerms) To UBound(arrTerms)
If rng Like arrTerms(J) & "*" Then
rng.EntireRow.Delete
End If
Next J
Next I
.Calculation = xlCalculationAutomatic
.ScreenUpdating = True
End With
End Sub
For I = Cells(Rows.Count, 1).End(xlUp).Row To 1 Step -1
Set rng = Cells(I, 6)
For J = LBound(arrTerms) To UBound(arrTerms)
If rng Like arrTerms(J) & "*" Then
rng.EntireRow.Delete
Exit For
End If
Next J
Next I
By the way, is there data in column A?
Option Explicit
Public Sub DelRows()
Dim dicWords As Object
Dim I As Long
Dim J As Long
Dim rng As Range
Set dicWords = CreateObject("scripting.dictionary")
dicWords.Add "Status", 1
dicWords.Add "WorkID", 1
dicWords.Add "P_Owners", 1
dicWords.Add "WorkStatus", 1
dicWords.Add "WorkIDs", 1
dicWords.Add "FunctionTitles", 1
dicWords.Add "FunctionIDAncestors", 1
dicWords.Add "DateCreate", 1
dicWords.Add "NameCreate", 1
dicWords.Add "DateLastEdit", 1
dicWords.Add "NameLastEdit", 1
dicWords.Add "$WebFlags", 1
dicWords.Add "$ConflictAction", 1
dicWords.Add "Phases", 1
dicWords.Add "Subform", 1
dicWords.Add "NumTests", 1
dicWords.Add "DescriptionText", 1
dicWords.Add "ExecCycleIDs", 1
dicWords.Add "ExecCycleTitles", 1
dicWords.Add "ExecAllCycleTitles", 1
dicWords.Add "ExecAllCycleIDs", 1
dicWords.Add "ExecAllResults_id", 1
dicWords.Add "ExecAllBuilds_id", 1
dicWords.Add "ExecAllid", 1
dicWords.Add "WorkExecAllDefects", 1
dicWords.Add "WorkEventLog001", 1
dicWords.Add "Work_OldValues", 1
dicWords.Add "$WorkUpdatedBy", 1
dicWords.Add "$WorkRevisions", 1
With Application
.Calculation = xlCalculationManual
.ScreenUpdating = False
For I = Cells(Rows.Count, 1).End(xlUp).Row To 1 Step -1
Set rng = Cells(I, 6)
If Len(rng.Value) = 0 Then
Else
If dicWords.exists(Split(rng.Value, " ")(0)) Then
rng.EntireRow.Delete
End If
End If
Next
.Calculation = xlCalculationAutomatic
.ScreenUpdating = True
End With
End Sub
If UCase(rng.Value) Like UCase("*" & arrTerms(J) & "*") Then
Option Explicit
Public Sub ExtractTitleAndSteps()
Dim rngFind As Range
Dim rngSteps As Range
Dim strTitle As String
Dim wksTemp As Worksheet
Dim wksCurrent As Worksheet
Set wksCurrent = ActiveSheet
Set rngFind = ActiveSheet.Range("A:A").Find("Title: ")
If rngFind Is Nothing Then
MsgBox "No title found"
Exit Sub
Else
strTitle = rngFind.Value
strTitle = Trim(Mid$(strTitle, Len("Title: ") + 1))
End If
Set rngFind = ActiveSheet.Range("A:A").Find("Steps")
If rngFind Is Nothing Then
MsgBox "No steps found"
Exit Sub
Else
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Set rngSteps = ActiveSheet.Range(rngFind, rngFind.End(xlDown).Offset(0, 1))
Set wksTemp = Application.Worksheets.Add
wksTemp.Range("A1").Value = strTitle
rngSteps.Copy wksTemp.Range("B1", wksTemp.Range("B1").Offset(rngSteps.Rows.Count, rngSteps.Columns.Count))
wksCurrent.Range("A:B").Value = vbNullString
wksCurrent.Range("A1", wksCurrent.Range("A1").Offset(rngSteps.Rows.Count, rngSteps.Columns.Count + 1)).Value = _
wksTemp.Range("A1", wksTemp.Range("A1").Offset(rngSteps.Rows.Count, rngSteps.Columns.Count + 1)).Value
wksTemp.Delete
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End If
End Sub
Option Explicit
Public Sub ExtractTitleAndSteps()
Dim rngFind As Range
Dim rngFirstFind As Range
Dim rngSteps As Range
Dim rngTgt As Range
Dim strTitle As String
Dim wksTemp As Worksheet
Dim wksCurrent As Worksheet
Set wksCurrent = ActiveSheet
Set rngFind = wksCurrent.Range("A:A").Find("Title: ")
If rngFind Is Nothing Then
MsgBox "No title found"
Exit Sub
Else
Set rngFirstFind = rngFind
End If
Set wksTemp = Application.Worksheets.Add
Set rngTgt = wksTemp.Range("A1")
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Do Until rngFind Is Nothing
strTitle = rngFind.Value
Set rngFind = wksCurrent.Range(rngFind, wksCurrent.Range("A:A").Rows(wksCurrent.Rows.Count).End(xlUp)).Find("Steps", rngFind)
If rngFind Is Nothing Then
MsgBox "No steps found following " & strTitle
Exit Sub
Else
Set rngSteps = wksCurrent.Range(rngFind, rngFind.End(xlDown).Offset(0, 1))
rngTgt.Value = strTitle
rngSteps.Copy wksTemp.Range(rngTgt.Offset(0, 1), rngTgt.Offset(rngSteps.Rows.Count, rngSteps.Columns.Count + 1))
End If
Set rngFind = wksCurrent.Range(rngFind, wksCurrent.Range("A:A").Rows(wksCurrent.Rows.Count).End(xlUp)).Find("Title: ", rngFind)
If rngFind Is Nothing Then
Else
If rngFind.Address = rngFirstFind.Address Then
Exit Do
End If
End If
Set rngTgt = rngTgt.Offset(rngSteps.Rows.Count + 1)
Loop
wksCurrent.Range("A:B").Value = vbNullString
wksCurrent.Range("A1", wksTemp.Cells.SpecialCells(xlCellTypeLastCell).Address).Value = _
wksTemp.Range("A1", wksTemp.Cells.SpecialCells(xlCellTypeLastCell).Address).Value
wksTemp.Delete
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub
If you are experiencing a similar issue, please ask a related question
Title | # Comments | Views | Activity |
---|---|---|---|
Combine like values in a graph excel 2016 | 7 | 35 | |
How to Get a Count of Unique Values and paste them on a different tab | 3 | 19 | |
remove extra space at end of cell | 12 | 35 | |
remove everything in an excel cell, except for the email address | 7 | 17 |
Join the community of 500,000 technology professionals and ask your questions.