Solved

Help in modifying a VBA code.

Posted on 2011-09-02
14
339 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
ID: 36473190
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
ID: 36473572
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
ID: 36473759
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
ID: 36474039
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
ID: 36474081
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
ID: 36474123
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
ID: 36474339
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
Is Your Active Directory as Secure as You Think?

More than 75% of all records are compromised because of the loss or theft of a privileged credential. Experts have been exploring Active Directory infrastructure to identify key threats and establish best practices for keeping data safe. Attend this month’s webinar to learn more.

 
LVL 24

Expert Comment

by:StephenJR
ID: 36474396
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
ID: 36474506
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
ID: 36474523
Dummy data will be fine as long as it is representative. Then I can test the code too.
0
 

Author Comment

by:Olympia275
ID: 36474873
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
ID: 36474924
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
ID: 36485771
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
ID: 36487610
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

Is Your Active Directory as Secure as You Think?

More than 75% of all records are compromised because of the loss or theft of a privileged credential. Experts have been exploring Active Directory infrastructure to identify key threats and establish best practices for keeping data safe. Attend this month’s webinar to learn more.

Question has a verified solution.

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

Introduction This Article briefly covers methods of calculating the NPV and IRR variants in Excel as well as the limitations in calculating and interpreting IRR results. Paraphrasing Richard Shockley, author of my favourite finance reference tex…
This article descibes how to create a connection between Excel and SAP and how to move data from Excel to SAP or the other way around.
The viewer will learn how to use the =DISCRINV command to create a discrete random variable, use this command to model a set of probabilities and outcomes in a Monte Carlo simulation, and learn how to find the standard deviation of a set of probabil…
This Micro Tutorial will demonstrate the scrolling table in Microsoft Excel using the INDEX function.

920 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

14 Experts available now in Live!

Get 1:1 Help Now