Help in modifying a small VBA code.

One quick observation
1) your code has following sub that are not included
Call MyRemoveSpaces
Call deletewith

2) Sub findData() is not called anywhere in the presented code.

I suggest you post your workbook as is so we can better understand what you need to acheive as picking up pieces on info sometimes increases the confusion.

Presume this is why your question has not been addressed yet.
gowflow

Hi,

My workbook contains sensitive data and some other codes which may add to confusion.  If I may, let me explain it in simple terms.

First from a functional standpoint:

I'm copying from sheet2 “entire strings” that contain certain words, as long as the same string does not include some other specified words or characters; and I do not want exact duplicated strings.

The way the code is working “now”,

1.      I'm calling “Sub findData” from my web-Query code

2.      The “Sub findData” is searching for any string that contains a word, specified in my sheet3 dictionary

3.      I am then calling the “Sub removeduplicates”

4.      Lastly, I am calling “Sub deletenumber” and some other repeated codes, to eliminate some other words or characters.

Now, since I do not know how to eliminate everything that is in a specified dictionary, I have to call the same elimination code over and over, where I'm just changing the specified values to eliminate. (And the “Call deletewith” is just one example.  It is the same code as “Sub deletenumber” but rather than specifying “characters”, it is eliminating a string that contains the word “with”

Additionally, since this code does not run across all sheets, I have to rerun all these elimination codes for every sheet separately.  And this is the main part that I need to change.  Once this is changed, to eliminate everything included in my dictionary in sheet4, I no longer need to call “deletewith” “MyRemoveSpaces”

It will serve the purpose.  If you can just change this “Sub deletenumber” piece of code to work across all worksheets except 1,2,3,4, and to use a dictionary in sheet4 .  However, I was just thinking if it is possible to optimize the code where all of these three functions could be included in one piece. (Just if this is easy)

I hope this clarifies,

Thanks so much.

My “Sub findData”  has also been modified to eliminate duplicate sheets, And also removed three Unnecessary lines of code. See,

Sub findData()

Dim f As Range, fa As String, i As Long, r As Range, ws As Worksheet
Dim src As Worksheet, dst As Worksheet

Set src = Sheets("sheet2") 'sheet to be searched, change as required

i = 1

For Each r In Sheets("Sheet3").Range("A1", Sheets("Sheet3").Range("A" & Rows.Count).End(xlUp))
        
        Set f = src.Cells.Find(What:=r.Value, after:=src.Cells(1), LookIn:=xlFormulas, _
                               LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
                               MatchCase:=False, SearchFormat:=False)
        If Not f Is Nothing Then
            If Not SheetExists(r.Text) Then
                Set ws = Sheets.Add(after:=Sheets(Sheets.Count))
                ws.Name = r
            Else
                Set ws = Sheets(r.Text)
            End If
            fa = f.Address
            Do
                If Len(f.Value) < 80 Then
                    ws.Range("A" & Rows.Count).End(xlUp)(2) = f.Value
                    i = i + 1
                End If
                Set f = src.Cells.FindNext(f)
            Loop Until fa = f.Address
        End If
        fa = ""

Next r

End Sub

Function SheetExists(sName As String) As Boolean

On Error Resume Next
SheetExists = CBool(Len(Worksheets(sName).Name) > 0)

End Function

Select allOpen in new window

once you've added the words to the dictionary variable, you use the variable's .Exists() method.  That way, you only iterate the cells once.  If you are trying to do pattern matching, you will have to iterate a dictionary or collection object for each cell.

@Olympia275

Is the first row a header row or a data row?

the first row is also data. and I'm not searching patterns I'm just building a dictionary from Available strings.

I'm not sure if I understood your previous comment.  Are you talking about eliminating duplicates?  If so, you are  Correct we can use already exists.  However, my strings are spread out to multiple sheets, for every category match.  And this will also not help me with eliminating strings that contains specific characters…

what is available strings?

I'm filtering my data from sheet2 for Available Headers. with different categories.  The way I am Identifying them is by searching for certain words that I know It should be in each header,(Using different words for each header category) and eliminating those strings that also contain other characters that I know it should not be in Any Category header. I'm also using

 If Len(f.Value) < 80 Then 

Select allOpen in new window

to eliminate paragraphs.

I think I got confused with your previous comments.  I want to clarify, that my data in sheet2 keeps on changing, and every time the data changes, I run again the filters.

I recall that for one of your previous questions, you did upload a sample file - could you re-upload it?

Wow Stephen, thank you for joining...

Please see attached some dummy data using just A few URLs, bringing in simple webpage...
We are dealing with thousands of URLs and each URL contains a document of approximately 20 pages.

Sample-data.xlsm

Will see if I get time tomorrow to look if this is still unsolved.

Thanks.  And please let me know If I need to clarify anything...

In relation to your original point 1, the macro "removeduplicates" loops through all sheets and calls the other procedures so if you run it, all sheets should be dealt with. Or are you saying you want to run "deletenumber" independently?

Then, "we eliminate multiple characters and specific text from all output sheets (this is what we need to change)" - what exactly are these characters and text? I'm a bit lost as to whether this happens at all - I just can't visualise exactly what you envisage I'm afraid.

Basically what this is doing, it is searching for article headers and footers. (I then run another code, which is matching the header and footer and brings in everything in between)

Each sheet that I'm searching has multiple articles about different subjects.(I'm building a separate dictionary for articles about each subject)

Each article header curtains a word ‘related to that subject’ so I'm searching for that particular word however, the same word is multiplied throughout the sheet many times, so the first filter is, to eliminate long strings, (more than 80 characters, which is eliminating entire paragraphs.)  Then I want to eliminate other things that I know is not included in an article header, For example, the word “with” “and” “numbers” etc.

And no, I'm not interested to run anything separately…

And since I'm searching from thousands of documents I need to also eliminate duplicates

So based on what you are saying, that if I will call the code from the remove duplicates, will automatically apply the  code to all sheets, then all I need is, to create a dictionary for elimination characters, and call it from the remove duplicates…

The elimination characters could be in the deletenumber macro which is called by removeduplicates, but I think you need to give some examples of what goes in your dictionary.

You are correct, it could be the same deletenumber macro, however I need it to use an object, which defines a dictionary in sheet4 (the same as with your findData code, which defines a dictionary in sheet3), I don't want to specify in the code what I want to eliminate, and at this point I'm not even sure of everything that I need to eliminate and I will constantly be refining and adding more text to my dictionary, after reviewing my output results.

give it a try

Option Explicit
 
Sub saagar()
    Dim MyRg As Range
    Dim startrow As Long
    Dim lastrow As Long
    Dim X As Long
    Dim CurrentScreenUpdating
    Dim CurrentCalculate
    Dim CurrentEnableEvents
    Dim F As Range
    Dim compareval As String
    Dim likeval1 As String
    Dim likeval2 As String
    Dim likeval3 As String
    Dim likeval4 As String
     
    startrow = 2
    lastrow = Cells(Rows.Count, "A").End(xlUp).Row
     
    With Application
        CurrentScreenUpdating = .ScreenUpdating
        CurrentCalculate = .Calculation
        CurrentEnableEvents = .EnableEvents
        .ScreenUpdating = False
        .Calculation = xlCalculationManual
        .EnableEvents = False
    End With
     
    With Sheets("Sheet3")
        Set MyRg = .Range(.Cells(1, "B"), .Cells(Rows.Count, "B").End(xlUp))
        
        Dim ws As Worksheet
        For Each ws In Worksheets
        Select Case ws.Name
        Case "Sheet1", "Sheet2", "Sheet3" 'names of sheets to which code need not be applied do nothing
        Case Else
            ws.Activate
        
        For X = lastrow To startrow Step -1
            For Each F In MyRg
                compareval = LCase(Cells(X, "A").Value)
                likeval1 = "* " & LCase(F.Value) & " *" 'sentence contains word
                likeval2 = LCase(F.Value) & " *" 'sentence starts with word
                likeval3 = "* " & LCase(F.Value) 'sentence end with word
                likeval4 = LCase(F.Value) 'cell contains word only
                If compareval Like likeval1 Or compareval Like likeval2 Or compareval Like likeval3 Or compareval Like likeval4 Then
                    'Cells(X, "A").Clear
                    Cells(X, "A").EntireRow.Delete
                    Exit For
                End If
            Next F
        Next
    End Select
    
    Next ws
    
    End With
    With Application
        .ScreenUpdating = CurrentScreenUpdating
        .Calculation = CurrentCalculate
        .EnableEvents = CurrentEnableEvents
    End With
End Sub

Select allOpen in new window

and this code is taking care of your remove duplicates and number stuff as well

Option Explicit
 
Sub saagar()
    Dim MyRg As Range
    Dim startrow As Long
    Dim lastrow As Long
    Dim X As Long
    Dim Y As Long
    Dim CurrentScreenUpdating
    Dim CurrentCalculate
    Dim CurrentEnableEvents
    Dim F As Range
    Dim compareval As String
    Dim likeval1 As String
    Dim likeval2 As String
    Dim likeval3 As String
    Dim likeval4 As String
     
    startrow = 2
    lastrow = Cells(Rows.Count, "A").End(xlUp).Row
     
    With Application
        CurrentScreenUpdating = .ScreenUpdating
        CurrentCalculate = .Calculation
        CurrentEnableEvents = .EnableEvents
        .ScreenUpdating = False
        .Calculation = xlCalculationManual
        .EnableEvents = False
    End With
     
    With Sheets("Sheet3")
        Set MyRg = .Range(.Cells(1, "B"), .Cells(Rows.Count, "B").End(xlUp))
        
        Dim ws As Worksheet
        For Each ws In Worksheets
        Select Case ws.Name
        Case "Sheet1", "Sheet2", "Sheet3" 'names of sheets to which code need not be applied do nothing
        Case Else
            ws.Activate
            
        ws.Columns("A:A").Select
        ws.Range("A" & Rows.Count).End(xlUp).removeduplicates Columns:=1, Header:=xlNo

        Dim cell As Range
        For Each cell In Range("A1:A" & Cells(Rows.Count, "A").End(xlUp).Row)
        cell = Trim(cell.Text)
          
        startrow = 2
        lastrow = Cells(Rows.Count, "A").End(xlUp).Row
        For X = lastrow To startrow Step -1
        If Cells(X, "A").Value Like "*#*" Then Cells(X, "A").EntireRow.Delete
        
            For Each F In MyRg
                compareval = LCase(Cells(X, "A").Value)
                likeval1 = "* " & LCase(F.Value) & " *" 'sentence contains word
                likeval2 = LCase(F.Value) & " *" 'sentence starts with word
                likeval3 = "* " & LCase(F.Value) 'sentence end with word
                likeval4 = LCase(F.Value) 'cell contains word only
                If compareval Like likeval1 Or compareval Like likeval2 Or compareval Like likeval3 Or compareval Like likeval4 Then
                    'Cells(X, "A").Clear
                    Cells(X, "A").EntireRow.Delete
                    Exit For
                End If
            Next F
            
            Next
            
            Next cell
            
    End Select
    
    Next ws
    
    End With
    With Application
        .ScreenUpdating = CurrentScreenUpdating
        .Calculation = CurrentCalculate
        .EnableEvents = CurrentEnableEvents
    End With
End Sub

Select allOpen in new window

This code is brilliant; I really appreciate your assistance.