Solved

Help in modifying a VBA code.

Posted on 2011-09-02
14
326 Views
Last Modified: 2012-05-12
Hello experts,

I have this code below which is searching for multiple strings, defined with the object "r" and creates a new Sheet for each category. The problem is that my data source keeps on updating in a loop and I keep on rerunning this code, which consequently tries to re-create the same sheets over and over.  So I need to add the following.

before creating a new sheet it should check whether the sheet already exists, and if so add the data to the bottom of it, if not create a new sheet.

I would also like to add a function, which will run every time at the end of this code, to delete the duplicates from every sheet separately, defined with the object "r".

Thank you.
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
            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 = ""

Next r

End Sub

Open in new window

0
Comment
Question by:Olympia275
  • 8
  • 6
14 Comments
 
LVL 24

Expert Comment

by:StephenJR
Comment Utility
Try this for the first bit. Not sure what you mean by the second - do you mean the values in sheet3 contain duplicates?
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
 

Author Comment

by:Olympia275
Comment Utility
Hi,

Your code works perfectly.  Now for the second part: I'm talking about the output files, I'm building a dictionary based on the Strings found, (defined with object "r") and I do not want in my output dictionary duplicates.
The reason I have to run it right after this code, since I'm getting so much data, (I’m filtering thousands of documents, and we have thousands of duplicates), so we have to constantly remove them in order to let my loop work efficiently.
I hope this clarifies.
You can see below the code that I am using now, Right now I'm calling, every sheet by its direct name.
Thank you.

Sub removeduplicates()
    Sheets("Mysheetname").Select
    Columns("A:A").Select
    Call MyRemoveSpaces
    Sheets("Mysheetname").Range("A" & Rows.Count).End(xlUp).removeduplicates Columns:=1, Header:= _
    xlNo  
Call deletenumber
Call deletewith
End Sub

Open in new window

0
 
LVL 24

Expert Comment

by:StephenJR
Comment Utility
Hmm I think so, but wouldn't it be easier to get a list of unique items from sheet3 at the beginning rather than delete them at the end?
0
 

Author Comment

by:Olympia275
Comment Utility
Well, let me explain you what I am doing.

I'm searching for multiple defined texts that I know it should be in the strings that I'm looking for.  ‘I do not know the entire string’, so for example if I would be searching for all articles about EE, I may be searching for the following “experts exchange” which can be a part of a string such as “An expert developer from experts exchange” so when I bring in the next document, I want to make sure that I'm still getting will articles about experts exchange, but they should not get the same article over and over.  (Obviously this is just an example but it is even more accurate for the data that I'm searching for)

Right now what I am doing is, I'm for is calling a code which is removing the spaces.  So it correctly identifies the duplicate.

After removing the duplicates, I'm calling other codes which are specifying certain characters or text that I want to eliminate from the string.  See the code below, and for this actually I would want to do the same as you suggested.  To define in a dictionary what characters it should be eliminated.  Rather than specifying in the code.

Thanks so much.

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

0
 

Author Comment

by:Olympia275
Comment Utility
I'm actually calling more elimination codes then what's posted above. So if you can help me Specify this piece of code with an object, perhaps column B in sheet3.  Would be great.

Thank you,
0
 
LVL 24

Accepted Solution

by:
StephenJR earned 500 total points
Comment Utility
If it's just a case then of extending your code above to all sheets, try this:
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

However, with the above you would have to modify the procedures you are calling to refer to the active sheet. Alternatively, the other procedures could be modified to accept a worksheet argument if you didn't want this.
0
 

Author Comment

by:Olympia275
Comment Utility
I'm getting an error on

Open in new window

ws.Range("A" & Rows.Count).End(xlUp).removeduplicates Columns:=1, Header:=xlNo

Even after I have removed all other procedures

I'm not sure if I understood exactly your comments, but it made me think of another idea.  Rather than calling other functions to eliminate characters and delete duplicates.  Why not put validation in the original piece of code.  Basically, saying that search everything identified in “object r” then match each string found with the other sheets, except 2 and 3.  If it is already there then don't save, else save.

I believe this should solve everything except from removing spaces.  See my code below, let me know if this is feasible, and if you can implement them altogether.

Thanks so much.
Sub MyRemoveSpaces()
 
    Dim cell As Range
    For Each cell In Range("A1:A" & Cells(Rows.Count, "A").End(xlUp).Row)
        cell = Trim(cell.Text)
    Next cell
    
End Sub

Open in new window

0
How to run any project with ease

Manage projects of all sizes how you want. Great for personal to-do lists, project milestones, team priorities and launch plans.
- Combine task lists, docs, spreadsheets, and chat in one
- View and edit from mobile/offline
- Cut down on emails

 
LVL 24

Expert Comment

by:StephenJR
Comment Utility
Undoubtedly, but I'm getting a bit confused now as to exactly what needs doing. Are you able to post a small sample workbook which demonstrates your various procedures?
0
 

Author Comment

by:Olympia275
Comment Utility
Unfortunately, I cannot post the workbook since it contains a lot of sensitive data, but I'll explain in details.

Sheet1 contains a list of a few thousand URLs,

I'm running a code that takes in a loop, a URL placing it in sheet2 A: 1, which triggers a worksheet change that starts the web-query code, which brings in the entire HTML web-document to sheet2, which can fill up the entire sheet except row 1.

I'm then filtering these documents, for specific strings.  As previously mentioned, and defined with your object r, where sheet3 column A is used as a dictionary, for positive strings.

We now need to eliminate all duplicates and negative characters, as previously discussed...In order to correctly identify the duplicates, we are removing the spaces...

Then the loop is taking the next URL… and overwriting the previous document in sheet2, and so on the entire process, for each URL...

Please let me know if this clarifies, otherwise I'll try to create a workbook with dummy data.

Thanks so much for your help.


0
 
LVL 24

Expert Comment

by:StephenJR
Comment Utility
Dummy data will be fine as long as it is representative. Then I can test the code too.
0
 

Author Comment

by:Olympia275
Comment Utility
Hi,

I'm sorry it took me so long.  I had to clean up the old code and I tried to make the best simulation.
Please see attached. you enter the start button, in sheet2 which is taking data from sheet1 column B or you can manually enter in sheet2 column A:1 Any URL from sheet1

Please let me know if it's working for you.

Thank you.


Dummy-data.xlsm
0
 

Author Comment

by:Olympia275
Comment Utility
Hi, I mistakenly forgot to add

Open in new window


Function SheetExists(sName As String) As Boolean

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

End Function
0
 

Author Closing Comment

by:Olympia275
Comment Utility
Stephen,

I greatly appreciate your help.  I think I have confused you at he end, I'm accepting a solution and I am posting here http://www.experts-exchange.com/Software/Office_Productivity/Office_Suites/MS_Office/Excel/Q_27292209.html what I still need.

I appreciate if you can help me there.  I think now it is very clear...
0
 
LVL 24

Expert Comment

by:StephenJR
Comment Utility
No, didn't have time to look really. I might have been confused had I looked I suppose! Thanks for the points.
0

Featured Post

6 Surprising Benefits of Threat Intelligence

All sorts of threat intelligence is available on the web. Intelligence you can learn from, and use to anticipate and prepare for future attacks.

Join & Write a Comment

Introduction While answering a recent question (http:/Q_27311462.html), I created an alternative function to the Excel Concatenate() function that you might find useful.  I tested several solutions and share the results in this article as well as t…
Approximate matching with VLOOKUP and MATCH seems to me to be a greatly under-used technique, and one which is vital for getting good performance out of large lookups. Until recently I would always have advised using an exact match for simplicity an…
This Micro Tutorial will demonstrate in Microsoft Excel how to add style and sexy appeal to horizontal bar charts.
This Micro Tutorial will demonstrate how to use a scrolling table in Microsoft Excel using the INDEX function.

743 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

15 Experts available now in Live!

Get 1:1 Help Now