Find value and delete all rows below it

[rachel06]

Hi!

I'm having trouble with some of my code. This is what I have right now. What I want it to do is find "Customer Direct Change" and delete all rows below it. Note that that isn't the entire contents of the cell, so I have it doing a partial search

Sheets("Rate Sheet Language").Cells.Find(What:="Customer Directed Change", After:=ActiveCell, LookIn:= _
        xlFormulas2, LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:= _
        xlNext, MatchCase:=False, SearchFormat:=False).Delete

Please know I'm only looking to modify this so it can just sit in my existing code. I don't want an entirely new script.

And I know this is only deleting that row, I'm just struggling to get it to do more than this.

Thanks!!

 

[HighAndWilder]

Hi!

I'm having trouble with some of my code. This is what I have right now. What I want it to do is find "Customer Direct Change" and delete all rows below it. Note that that isn't the entire contents of the cell, so I have it doing a partial search

Sheets("Rate Sheet Language").Cells.Find(What:="Customer Directed Change", After:=ActiveCell, LookIn:= _
        xlFormulas2, LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:= _
        xlNext, MatchCase:=False, SearchFormat:=False).Delete

Please know I'm only looking to modify this so it can just sit in my existing code. I don't want an entirely new script.

And I know this is only deleting that row, I'm just struggling to get it to do more than this.

Thanks!!

Hi again.

Give this a go on a copy of your data.

Change the reference to column A as appropriate. There are three references..

Public Sub subDeleteRows()
Dim Ws As Worksheet
Dim rngFound As Range

  ActiveWorkbook.Save
  
  Set Ws = Worksheets("Rate Sheet Language")
  
  Set rngFound = Ws.Range("A:A").Find(What:="Customer Directed Change", After:=Ws.Range("A1"), LookIn:= _
          xlFormulas2, LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:= _
          xlNext, MatchCase:=False, SearchFormat:=False)

  If Not rngFound Is Nothing Then

    Range(rngFound.Offset(1, 0), Ws.Cells(Ws.Rows.Count, "A").End(xlUp)).EntireRow.Delete

  End If
  
End Sub

 

[MikeVol]

Hello @rachel06.
Try next updated code:

    Dim foundCell   As Range
    Set foundCell = ThisWorkbook.Worksheets("Rate Sheet Language").Cells.Find(What:="Customer Directed Change", After:=ActiveCell, LookIn:= _
            xlFormulas2, LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:= _
            xlNext, MatchCase:=False, SearchFormat:=False)

    If Not foundCell Is Nothing Then
        ThisWorkbook.Worksheets("Rate Sheet Language").Rows(foundCell.Row + 1 & ":" & ThisWorkbook.Worksheets("Rate Sheet Language").Rows.Count).Delete
    End If

    Set foundCell = Nothing

Good luck.

 

[rachel06]

I'm starting to think there's a better way to do this.

Essentially, my macro is looping through a bunch of workbooks and searching for the row that that includes "calculation of the," and then copy the rows below it. However, when I use (Selection, Selection.End(xlDown)).Copy, it's including blank/empty cells, and the data below them which I don't want. . These workbooks are protected, so I can't edit them which is a bummer because I would just need to text to columns.

Right now I'm trying to grab all that language, copy it over to my master workbook, but maybe that's too much work?

Is there a way to tweak this so that it doesn't include empty/blank cells?

    Cells.Find(What:="calculation of the", After:=ActiveCell, LookIn:= _
        xlFormulas2, LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:= _
        xlNext, MatchCase:=False, SearchFormat:=False).Activate
        Range(Selection, Selection.End(xlDown)).Copy

 

[HighAndWilder]

I'm starting to think there's a better way to do this.

Essentially, my macro is looping through a bunch of workbooks and searching for the row that that includes "calculation of the," and then copy the rows below it. However, when I use (Selection, Selection.End(xlDown)).Copy, it's including blank/empty cells, and the data below them which I don't want. . These workbooks are protected, so I can't edit them which is a bummer because I would just need to text to columns.

Right now I'm trying to grab all that language, copy it over to my master workbook, but maybe that's too much work?

Is there a way to tweak this so that it doesn't include empty/blank cells?

    Cells.Find(What:="calculation of the", After:=ActiveCell, LookIn:= _
        xlFormulas2, LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:= _
        xlNext, MatchCase:=False, SearchFormat:=False).Activate
        Range(Selection, Selection.End(xlDown)).Copy

There will nearly always be a better way.

Can you copy the worksheet and substitute the sensitive data for gobbledygook and highlight which values are to be copied to the master sheet
and highlight which rows are to be deleted. Post using XL2BB or even just an image.

From the previous code the workbooks were not saved when closed so any deleted rows will be lost.

 

[rachel06]

I'd want this to select/copy "Calculation of the" through "Snow". But when I try to selection "Calculation of the" to the bottom of the data, , it's going all the way to "Administrative Fees." Some of them it doesn't, some it does. I won't have to delete anything if I can figure out how to just copy what I need. Anything below snow would be deleted though. In this case I'd be copying 11 rows, but it's not always 11 rows.

Again, these come from locked workbooks so I can't just text to columns

Pentegra Services, Inc. 0196-2946 Traditional Rate Sheet 1-1-2025.xlsx
	A	B	C	D	E
103	Calculation of the
104	Dogs
105	Cats
106	Bunnies
107	Birds
108	Grass
109	Tacos
110	Dirt
111	Mud
112	Rain
113	Snow
114
115	Customer Directed Change: blah blah blah there's usually a big boring paragraph here which is why the cell is so big but no one ever reads it probably.
116
117	Upon request The TPA offers free puppies!!!
118
119	Market Check:
120	· Customer may conduct market check
121	1
122	2
123	3
124	4
125	5
126	6
127	7
128	8
129	9
130	10
131	11
132	The market check will blah blah
133	· ingredient
134	· rebates
135	· administrative fees.
Pharmacy Pricing

Cells with Conditional Formatting
Cell	Condition		Cell Format	Stop If True
A14:F43,A46:F138	Expression	=$F14="Remove"	text	NO

 

[HighAndWilder]

I'd want this to select/copy "Calculation of the" through "Snow". But when I try to selection "Calculation of the" to the bottom of the data, , it's going all the way to "Administrative Fees." Some of them it doesn't, some it does. I won't have to delete anything if I can figure out how to just copy what I need. Anything below snow would be deleted though. In this case I'd be copying 11 rows, but it's not always 11 rows.

Again, these come from locked workbooks so I can't just text to columns

Pentegra Services, Inc. 0196-2946 Traditional Rate Sheet 1-1-2025.xlsx
	A	B	C	D	E
103	Calculation of the
104	Dogs
105	Cats
106	Bunnies
107	Birds
108	Grass
109	Tacos
110	Dirt
111	Mud
112	Rain
113	Snow
114
115	Customer Directed Change: blah blah blah there's usually a big boring paragraph here which is why the cell is so big but no one ever reads it probably.
116
117	Upon request The TPA offers free puppies!!!
118
119	Market Check:
120	· Customer may conduct market check
121	1
122	2
123	3
124	4
125	5
126	6
127	7
128	8
129	9
130	10
131	11
132	The market check will blah blah
133	· ingredient
134	· rebates
135	· administrative fees.
Pharmacy Pricing

Cells with Conditional Formatting
Cell	Condition		Cell Format	Stop If True
A14:F43,A46:F138	Expression	=$F14="Remove"	text	NO

Hi

This version finds the row containing the test 'Calculation of the' and then from the following row to the row above the first empty cell populates an array.

This array is used in the 'fncFindRange' function for the line by line comparison.

No copying and pasting is required.

No row deletion is needed.

The 'Rate Sheet Language' worksheet is not required.

Dim arr1() As Variant

Sub ListAllFilesVersion2()
Dim MyPath As String
Dim MyFile As String
Dim wb As Workbook
Dim FldrPicker As FileDialog
Dim sh As Worksheet
Dim i As Integer
Dim rngFound As Range

  ActiveWorkbook.Save

  Application.ScreenUpdating = False
  
  Set sh = ThisWorkbook.Sheets("Output")
  
  Set FldrPicker = Application.FileDialog(msoFileDialogFolderPicker)
  
      With FldrPicker
          .Title = "Please Select Folder"
          .AllowMultiSelect = False
          .ButtonName = "Select"
          If .Show = -1 Then
              MyPath = .SelectedItems(1) & "\"
          Else
              End
         End If
      End With
               
  MyFile = Dir(MyPath)
  
  i = 2

  Do While MyFile <> ""

    sh.Cells(i, 1) = MyFile
    
    i = i + 1
    
    'Open File
    Set wb = Workbooks.Open(Filename:=MyPath & MyFile)
    
    'Ensure Workbook has opened before moving on to next line of code
     DoEvents
     
    ' Find "Calculation of the"
    Set rngFound = wb.Sheets(1).Range("A:A").Find(What:="Calculation of the", _
      LookIn:=xlValues, LookAt:=xlPart)

    If Not rngFound Is Nothing Then
      
      ' Find the next empty cell going down.
      ' Populate array with values down until next blank cell.
      arr1 = Range(rngFound.Offset(1, 0), rngFound.Offset(1, 0).End(xlDown)).Value
      
    End If
  
    wb.Close SaveChanges:=False

    sh.Cells(i - 1, 2) = fncFindRange

    MyFile = Dir

  Loop

  Application.ScreenUpdating = True

  MsgBox "Finished", vbOKOnly, "Confirmation"
  
End Sub

Private Function fncFindRange() As String
Dim arr2() As Variant
Dim i As Integer
Dim n As Integer
Dim blnOK As Boolean
          
  For n = 1 To 3  ' << Change this 3 to the number of named ranges that you have.
      
    blnOK = True
    
    arr2 = Range("R_" & n).Value
    
    If UBound(arr1) = UBound(arr2) Then
       
      For i = 1 To UBound(arr1)
      
        If arr1(i, 1) <> arr2(i, 1) Then
          blnOK = False
        End If
 
      Next i
      
      If blnOK Then
        fncFindRange = "R_" & n
        Exit Function
      End If
   
   End If
      
  Next n
  
  fncFindRange = ""

End Function

 

[MikeVol]

Hello @rachel06,
I don't know if I understood you correctly. This code searches for a string with the text Calculation of the and from the found string it determines the first unfilled cell. The found range is copied to another sheet. Substitute your sheet names, read the comments in the code.

Option Explicit

Sub CopyCalculationData()
    Dim wsSource    As Worksheet
    Set wsSource = ThisWorkbook.Worksheets("Sheet1")    ' Replace with the name of your original sheet

    Dim wsTarget    As Worksheet
    Set wsTarget = ThisWorkbook.Worksheets("Sheet2")    ' Replace with the name of the target sheet

    ' Request text to search from the user
    Dim searchText  As String
    searchText = Application.InputBox("Enter text to search in the column A:", "Search text", Type:=2)

    If searchText = "" Then
        MsgBox "Search cancelled by user! ", vbExclamation
        Exit Sub
    End If

    ' Find the text "Calculation of the" in column A
    On Error Resume Next
    Dim rngStart    As Range
    Set rngStart = wsSource.Columns("A").Find(What:=searchText, LookIn:=xlValues, LookAt:=xlPart)

    '    ' If the search text is always the same, then uncomment this line and comment out all lines with the 'searchText' variable.
    '    Set rngStart = wsSource.Columns("A").Find(What:="Calculation of the", LookIn:=xlValues, LookAt:=xlPart)
    On Error GoTo 0

    If Not rngStart Is Nothing Then

        Dim lastRow As Long
        lastRow = rngStart.Row

        Do While wsSource.Cells(lastRow, "A").Value <> ""
            lastRow = lastRow + 1
        Loop

        lastRow = lastRow - 1

        Dim rngCopy As Range
        Set rngCopy = wsSource.Range(rngStart, wsSource.Cells(lastRow, rngStart.Column))

        Dim targetRow As Long
        targetRow = wsTarget.Cells(wsTarget.Rows.Count, "A").End(xlUp).Row + 1

        rngCopy.Copy Destination:=wsTarget.Cells(targetRow, "A")
        MsgBox "Data copied successfully! ", vbInformation
    Else
        MsgBox "Text 'Calculation of the' not found! ", vbExclamation
    End If

    Set rngCopy = Nothing
    Set rngStart = Nothing
    Set wsTarget = Nothing
    Set wsSource = Nothing
End Sub

Good luck.