Solved

Help in modifying a small VBA code.

Posted on 2011-09-05
24
221 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
[X]
Welcome to Experts Exchange

Add your voice to the tech community where 5M+ people just like you are talking about what matters.

  • Help others & share knowledge
  • Earn cash & points
  • Learn & ask questions
  • 13
  • 4
  • 3
  • +2
24 Comments
 
LVL 31

Expert Comment

by:gowflow
ID: 36487543
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
ID: 36488371
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
ID: 36488399
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
Instantly Create Instructional Tutorials

Contextual Guidance at the moment of need helps your employees adopt to new software or processes instantly. Boost knowledge retention and employee engagement step-by-step with one easy solution.

 
LVL 46

Expert Comment

by:aikimark
ID: 36488414
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 46

Expert Comment

by:aikimark
ID: 36488428
@Olympia275

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

Author Comment

by:Olympia275
ID: 36488448
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
ID: 36488476
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 46

Expert Comment

by:aikimark
ID: 36488478
what is available strings?
0
 

Author Comment

by:Olympia275
ID: 36488505
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
ID: 36488612
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
ID: 36488700
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
ID: 36488765
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
 
LVL 24

Expert Comment

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

Author Comment

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

Expert Comment

by:StephenJR
ID: 36495585
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
ID: 36495714
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
ID: 36495727
And since I'm searching from thousands of documents I need to also eliminate duplicates
0
 

Author Comment

by:Olympia275
ID: 36495783
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
ID: 36496938
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
ID: 36497023
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
ID: 36518801
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
ID: 36518846
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
ID: 36518870
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
ID: 36519043
This code is brilliant; I really appreciate your assistance.
0

Featured Post

Ready to get started with anonymous questions?

It's easy! Check out this step-by-step guide for asking an anonymous question on Experts Exchange.

Question has a verified solution.

If you are experiencing a similar issue, please ask a related question

How to get Spreadsheet Compare 2016 working with the 64 bit version of Office 2016
If you need to forecast numbers -- typically for finance -- the Windows and Mac versions of Excel 2016 have a basket of tools to get the job done.
This Micro Tutorial demonstrates using Microsoft Excel pivot tables, how to reverse engineer competitors' marketing strategies through backlinks.
This Micro Tutorial demonstrates in Microsoft Excel how to consolidate your marketing data by creating an interactive charts using form controls. This creates cool drop-downs for viewers of your chart to choose from.

635 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