Select from freelancers specializing in everything from database administration to programming, who have proven themselves as experts in their field. Hire the best, collaborate easily, pay securely and get projects done right.
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
Join the community of 500,000 technology professionals and ask your questions.