Solved

Help in modifying a small VBA code.

Posted on 2011-09-05
24
211 Views
Last Modified: 2012-06-21
I have this piece of code
Sub deletenumber()

StartRow = 2
LastRow = Cells(Rows.Count, "A").End(xlUp).Row
With Application
    CurrentCalculate = .Calculation
  CurrentEnableEvents = .EnableEvents
  .ScreenUpdating = False
  .Calculation = xlCalculationManual
  .EnableEvents = False
End With
For X = LastRow To StartRow Step -1
  If Cells(X, "A").Value Like "*#*" Then Cells(X, "A").EntireRow.Delete
Next
With Application
    .Calculation = CurrentCalculate
  .EnableEvents = CurrentEnableEvents
End With

End Sub

Open in new window

Which is removing certain characters specified in the code from a specific sheet also specified in the code and I need the following changes:
1.      It should work across all sheets, no matter how they are named.  Except sheet numbers 1, 2, 3, and 4. as with this code,
Sub removeduplicates()

Dim ws As Worksheet

For Each ws In Worksheets
    Select Case ws.Name
        Case "Sheet2", "Sheet3" 'names of sheets to which code need not be applied
            ' do nothing
        Case Else
            ws.Activate
            ws.Columns("A:A").Select
            Call MyRemoveSpaces
            ws.Range("A" & Rows.Count).End(xlUp).removeduplicates Columns:=1, Header:=xlNo
            Call deletenumber
            Call deletewith
    End Select
Next ws

End Sub

Open in new window

2.      It should use a dictionary in sheet4, where we can add multiple characters or strings that should be eliminated.  As with this code,
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
Set dst = Sheets("Mysheetname") 'sheet for output, change as required
i = 1

For Each r In Sheets("Sheet3").Range("A1", Sheets("Sheet3").Range("A" & Rows.Count).End(xlUp))
    With dst
        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
            Set ws = Sheets.Add(after:=Sheets(Sheets.Count))
            ws.Name = r
            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 = ""
    End With
Next r

End Sub

Open in new window

We use all of these three pieces of code in one loop as following,
1.      we searched the data based on a dictionary in sheet3 and each output goes to a separate sheet and gets named based on the dictionary (this code works perfectly)
2.      we remove the duplicates from all output sheets (this code works perfectly)
3.      we eliminate multiple characters and specific text from all output sheets (this is what we need to change)
I'm wondering if someone can help me structure these codes better, perhaps put them all in one…



0
Comment
Question by:Olympia275
  • 13
  • 4
  • 3
  • +2
24 Comments
 
LVL 29

Expert Comment

by:gowflow
Comment Utility
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
0
 

Author Comment

by:Olympia275
Comment Utility
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.
0
 

Author Comment

by:Olympia275
Comment Utility
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

Open in new window

0
 
LVL 45

Expert Comment

by:aikimark
Comment Utility
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.
0
 
LVL 45

Expert Comment

by:aikimark
Comment Utility
@Olympia275

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

Author Comment

by:Olympia275
Comment Utility
the first row is also data. and I'm not searching patterns I'm just building a dictionary from Available strings.
0
 

Author Comment

by:Olympia275
Comment Utility
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…
0
 
LVL 45

Expert Comment

by:aikimark
Comment Utility
what is available strings?
0
 

Author Comment

by:Olympia275
Comment Utility
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 

Open in new window

to eliminate paragraphs.
0
 

Author Comment

by:Olympia275
Comment Utility
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.
0
 
LVL 24

Expert Comment

by:StephenJR
Comment Utility
I recall that for one of your previous questions, you did upload a sample file - could you re-upload it?
0
 

Author Comment

by:Olympia275
Comment Utility
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
0
Enabling OSINT in Activity Based Intelligence

Activity based intelligence (ABI) requires access to all available sources of data. Recorded Future allows analysts to observe structured data on the open, deep, and dark web.

 
LVL 24

Expert Comment

by:StephenJR
Comment Utility
Will see if I get time tomorrow to look if this is still unsolved.
0
 

Author Comment

by:Olympia275
Comment Utility
Thanks.  And please let me know If I need to clarify anything...
0
 
LVL 24

Expert Comment

by:StephenJR
Comment Utility
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.
0
 

Author Comment

by:Olympia275
Comment Utility
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…
0
 

Author Comment

by:Olympia275
Comment Utility
And since I'm searching from thousands of documents I need to also eliminate duplicates
0
 

Author Comment

by:Olympia275
Comment Utility
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…
0
 
LVL 24

Expert Comment

by:StephenJR
Comment Utility
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.
0
 

Author Comment

by:Olympia275
Comment Utility
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.
0
 
LVL 1

Expert Comment

by:NYQuicksale
Comment Utility
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

Open in new window

0
 
LVL 1

Expert Comment

by:NYQuicksale
Comment Utility
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

Open in new window

0
 
LVL 1

Accepted Solution

by:
NYQuicksale earned 500 total points
Comment Utility
finally  "Find data" "remove duplicates" "remove numbers" "delete text" in one code
hope this helps

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
    Dim G As Range
    Dim fa As String
    Dim i As Long
    Dim r As Range
    Dim ws As Worksheet
    Dim src As Worksheet
    Dim 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 G = src.Cells.Find(what:=r.Value, after:=src.Cells(1), LookIn:=xlFormulas, _
                               lookat:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
                               MatchCase:=False, SearchFormat:=False)
    If Not G 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 = G.Address
            Do
                If Len(G.Value) < 80 Then
                    ws.Range("A" & Rows.Count).End(xlUp)(2) = G.Value
                    i = i + 1
                End If
                Set G = src.Cells.FindNext(G)
            Loop Until fa = G.Address
            End If
        fa = ""
    Next r
    
    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))
        
        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
Function SheetExists(sName As String) As Boolean

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

End Function

Open in new window

0
 

Author Closing Comment

by:Olympia275
Comment Utility
This code is brilliant; I really appreciate your assistance.
0

Featured Post

Better Security Awareness With Threat Intelligence

See how one of the leading financial services organizations uses Recorded Future as part of a holistic threat intelligence program to promote security awareness and proactively and efficiently identify threats.

Join & Write a Comment

A little background as to how I came to I design this code: Around 5 years ago I designed an add-in that formatted Excel files to a corporate standard, applying different cell colours and font type depending on whether the cells contained inputs,…
Improved? Move/Copy Add-in Replacement - How to avoid the annoying, “A formula or sheet you want to move or copy contains the name XXX, which already exists on the destination worksheet.” David Miller (dlmille)  It was one of those days… I wa…
This Micro Tutorial demonstrates how to create Excel charts: column, area, line, bar, and scatter charts. Formatting tips are provided as well.
This Micro Tutorial will demonstrate in Google Sheets how to use the HYPERLINK function to create live links inside your spreadsheet.

762 members asked questions and received personalized solutions in the past 7 days.

Join the community of 500,000 technology professionals and ask your questions.

Join & Ask a Question

Need Help in Real-Time?

Connect with top rated Experts

10 Experts available now in Live!

Get 1:1 Help Now