Posts by DWildman

Re: Astricks for the first five numbers in a SSN

Yea from the best of my knowledge there is no simple formatting solution that will accomplish this task directly.

Re: Find text in column then select non blank cells to right, and repeat

I would try this...

http://www.ozgrid.com/VBA/find-method.htm

Re: Astricks for the first five numbers in a SSN

Just insert a new column next to your SSN column and use a formula to isolate the last 4 digits. For example if your SSN's are in column A, place the following formula in a new column...

="*****"&RIGHT(A2,4)

You can then just hide the full SSN column before printing.

If this isnt what you are looking for then please provide additional details regarding how your data is set up.

Re: Text To Rows Macro

Hello,

As I mentioned way back when...

Quote

the Split function only works in Excel 2000 and up

If you cannot use a more recent version of Excel, you may find the following thread helpful
http://www.ozgrid.com/forum/showthread.php?t=14109

Hope it helps!

Re: Script To Query Zillow.com, Realestateabc.com Or Cyberhomes.com

Hi Veradus,

Unfortunately this type of request doesnt have a straightforward solution but I threw something together for one of the sites you specified in the attached file. I rearranged the columns of your sheet a little and for some address+zip code combos there is no exact match, in which case the sub will result in a blank estimate. I havent been able to contibute to the forum lately so if anyone else would like to jump in here that would be great. Otherwise, if you can provide more test cases I will try to hook you up with a full solution when I can. Here is the code used....

Option Explicit


Sub Get_Quotes()


    Dim objIE As InternetExplorer
    Dim hDoc As MSHTML.HTMLDocument
    Dim lRow As Long
    Dim str As String
    Dim strEst As String
    
    Set objIE = CreateObject("InternetExplorer.Application")
    
    With objIE
        .Visible = True
        .navigate "http://www.zillow.com/"
        
        For lRow = 2 To Range("A" & Rows.Count).End(xlUp).Row
        
            Do While .Busy: DoEvents: Loop
            Do While .readyState <> 4: DoEvents: Loop
        
            Set hDoc = .document
            hDoc.getElementsByName("addrstrthood").Item(0).Value = Sheets("MAIN").Range("A" & lRow)
            hDoc.getElementsByName("citystatezip").Item(0).Value = Sheets("MAIN").Range("D" & lRow)
            hDoc.getElementById("GOButton").Click
        
            Do While .Busy: DoEvents: Loop
            Do While .readyState <> 4: DoEvents: Loop
        
            Set hDoc = .document
            
            Do While .Busy: DoEvents: Loop
            Do While .readyState <> 4: DoEvents: Loop
            
            str = CStr(hDoc.getElementById("address-result").innerHTML)
            
            Do While .Busy: DoEvents: Loop
            Do While .readyState <> 4: DoEvents: Loop
            
            If InStr(1, str, "ZST") = 0 Then
                strEst = ""
            Else
                strEst = Mid(str, InStr(1, str, "ZST") + 6, _
                InStr(InStr(1, str, "ZST") + 6, str, Chr(34)) - (InStr(1, str, "ZST") + 6))
            End If
            
            Sheets("MAIN").Range("E" & lRow) = strEst
            
        Next lRow
        
    End With
    
    Set objIE = Nothing
    
End Sub

This is still a little unrefined but let me know how it works. I have found that you may get different results depending on OS and XL version.

Hope it helps
DWildman

Re: Bold Common Text In 2 Strings

Hi gruebz,

I went with a bit of a different method, which is fairly solid but also needs a few adjustments.

• Given 2 strings (str1 and str2)
• Extract first word from each string and compare
• If words are same, get next word
• If words are different
• Bold str2 word and then see if any other str2 words match the str1 word
• If any other str2 words match, then assume that words/phrases have been inserted into the middle of the original phrase
• Remove that word from the str2 variable...as if it doesnt exist
• Continue

I apologize if Im being a bit vague with my explaination. I think I went with a bad approach by strictly manipulating strings (I think it might be easier storing each word in an array and working with that).

Anyway...The flaw exists if there are duplicate words in String2 Ill check it tomorrow.

Sub Str_Comp_Bold()
     
    Dim strMainStr As String
    Dim str1 As String
    Dim str2 As String
    Dim strWrd1 As String
    Dim strWrd2 As String
    Dim strTmp As String
    Dim strTmpWrd As String
     
    strMainStr = UCase(Range("A3"))
    str1 = UCase(Range("A2"))
    str2 = UCase(Range("A3"))
     
    Do
        If InStr(1, str1, " ") = 0 Then
            strWrd1 = str1
            str1 = ""
        Else
            strWrd1 = Trim(Left(str1, InStr(1, str1, " ")))
            str1 = Right(str1, Len(str1) - Len(strWrd1) - 1)
        End If
         
        If InStr(1, str2, " ") = 0 Then
            strWrd2 = str2
            str2 = ""
        Else
            strWrd2 = Trim(Left(str2, InStr(1, str2, " ")))
            str2 = Right(str2, Len(str2) - Len(strWrd2) - 1)
        End If
         
        If strWrd1 <> strWrd2 Then
            Range("A3").Characters(Start:=InStr(1, strMainStr, strWrd2), _
            Length:=Len(strWrd2)).Font.FontStyle = "Bold"
            
            strTmp = str2
          
            Do
                If Len(strTmp) = 0 Then
                    Exit Do
                ElseIf InStr(1, strTmp, " ") = 0 Then
                    strTmpWrd = strTmp
                    strTmp = ""
                Else
                    strTmpWrd = Trim(Left(strTmp, InStr(1, strTmp, " ")))
                    strTmp = Right(strTmp, Len(strTmp) - Len(strTmpWrd) - 1)
                End If
                
                If strTmpWrd = strWrd1 Then
                    'MsgBox "str2 = " & str2 & vbCrLf & "strtmpwrd = " & strTmpWrd
                    str2 = Left(str2, InStr(1, str2, strTmpWrd) - 1) & _
                           Right(str2, Len(str2) - InStr(1, str2, strTmpWrd) - Len(strTmpWrd))
                    Exit Do
                End If
                
            Loop While InStr(1, strTmp, " ") <> 0
            
        End If
         
     Loop While Not str2 = ""
     
End Sub

Cool problem
-DWildman

Re: Bold Common Text In 2 Strings

Quote from gruebz

I know this is a tricky one and may be impossible to do the way I am wanting to do it.

Well, that will be a bit of a challenge. Certainly not impossible (hard for me to believe anything is).... I will give it a rip.

Re: Bold Common Text In 2 Strings

Hi gruebz,

As per previous post it seems that a word comparison will suit your needs rather than a true string compare. The following sub compares each word in string2 to the corresponding word in string1 and bolds the string2 word if it does not occur at the same position in string1.

Sub Str_Comp_Bold()


    Dim str1 As String
    Dim str2 As String
    Dim strWrd1 As String
    Dim strWrd2 As String
    Dim iPos As Integer
    
    str1 = UCase(Range("A2"))
    str2 = UCase(Range("A3"))
    iPos = 1
    
    Do
        If InStr(1, str1, " ") = 0 Then
            strWrd1 = str1
            str1 = ""
        Else
            strWrd1 = Trim(Left(str1, InStr(1, str1, " ")))
            str1 = Right(str1, Len(str1) - Len(strWrd1) - 1)
        End If
    
        If InStr(1, str2, " ") = 0 Then
            strWrd2 = str2
            str2 = ""
        Else
            strWrd2 = Trim(Left(str2, InStr(1, str2, " ")))
            str2 = Right(str2, Len(str2) - Len(strWrd2) - 1)
        End If
        
        If strWrd1 <> strWrd2 Then
            Range("A3").Characters(Start:=iPos, Length:=Len(strWrd2)).Font.FontStyle = "Bold"
        End If
        
        iPos = iPos + Len(strWrd2) + 1
        
    Loop While Not str2 = ""
     
End Sub

String1 must be in cell A2 and string2 in cell A3.

Let me know how it works out for you.
-DWildman

Re: Compare 2 Strings and Bold the Result

Just to clarify...are you actually just looking for a word comparison? How precise are you looking to get. For example:

Str1 = "Hello World"
Str2 = "Hello Wurld"

Would you like all of "Wurld" bolded or just the "u"? Or shall we assume that every word will always be correctly spelled?

-DWildman

Re: Add New Worksheet & Include It In Function Added By Code

Sorry I misunderstood the question. Try this...

Sheets("Data Table").Range("IV4").End(xlToLeft)(1).Offset(0, 1) = resp
    Sheets("Data Table").Range("IV6").End(xlToLeft)(1).Offset(0, 1).FormulaR1C1 = "=" & resp & "!R1C1:R200C1"

Re: Referencing Worksheets With Variable Name

Hi Sam - Welcome to the forum!
If resp is a string variable which contains a worksheet name, then you can reference the worksheet using that variable with...

Sheets(resp).Range("A1:A200")

Also, Im pretty sure that assigning a range to a single cell doesnt work (someone correct if Im wrong). So changing your last line to...

ActiveCell.FormulaR1C1 = Sheets(resp).Range("A1:A200")

wont quite do what your looking for. Instead I think a copy-paste is what you need. This code should work out for you...

Sub Test()


    Sheets("Data Table").Range("IV4").End(xlToLeft)(1).Offset(0, 1) = resp
    Sheets(resp).Range("A1:A200").Copy
    Sheets("Data Table").Range("IV6").End(xlToLeft)(1).Offset(0, 1).PasteSpecial


End Sub

Note that using Select/Activate/ActiveCell can be eliminated

Hope it helps
DWildman

Re: Concatenate & Paste Visible Cells

Quote

For anyone else reading this, I would appreciate any corrections or simplifications that could have been made. Thanks.

Just as a simplification, using Select/Selection/Activate is hardly (if ever) necessary. Also, if you are maintaining a "Concatenate" column, you would want to paste over only the values and not the formula as this would yield incorrect results. I would also go one step further and reference the CONCAT column and column D dynamically so if rows are added, the code would not need to be changed. So something like this...

Sub CopyPasteSelectedCells()
     '
     ' CopyPasteSelectedCells Macro
     '
     ' Keyboard Shortcut: Ctrl+Shift+C
    Worksheets("Sheet1").Range("C2:C" & Range("C" & Rows.Count).End(xlUp).Row).SpecialCells(xlCellTypeVisible).Copy
    Worksheets("Stats").Range("A38").PasteSpecial xlValues
    Worksheets("Sheet1").Range("D2:D" & Range("D" & Rows.Count).End(xlUp).Row).SpecialCells(xlCellTypeVisible).Copy
    Worksheets("Stats").Range("B38").PasteSpecial xlValues
     
End Sub

Hope it helps
-DWildman[hr]*[/hr] Auto Merged Post;[dl]*[/dl]Sorry...I am assuming that a CONCATENATE column is being maintained in columns C

Re: Open CSV Files By Date

Hi Leif,

Sry for the late reply...

I cant see why you are getting a "file not found" error if the workbook containing the macro is in the same folder as the file that you need to open. The previous code I provided works fine for me but you can try this...

Workbooks.OpenText filename:=ThisWorkbook.path & "\" & sNewest

Hope it helps
-DWildman

Re: Open CSV Files By Date

Workbooks.OpenText sNewest

Re: Open CSV Files By Date

Ooppps...Sorry, your right. I made a mistake (see code).

Sub Recent()
     
    Dim sFileXls As String
    Dim sNewest As String
    Dim dLstMod As Date
     
    sFileXls = Dir(ThisWorkbook.Path & "\*.csv")
     
    Do While sFileXls <> ""
        If FileDateTime(ThisWorkbook.Path & "\" & sFileXls) > dLstMod Then
            dLstMod = FileDateTime(ThisWorkbook.Path & "\" & sFileXls)
            [COLOR="DarkOrange"]sNewest = [B][I]sFileXls[/I][/B][/COLOR]
        End If
        sFileXls = Dir()
    Loop
     
     MsgBox "Most recent updated file = " & sNewest
     
End Sub

My previous code was calling the Dir() function again at that line and getting the next file prematurely. This should now be what your looking for.

Quote

I am wondering if the solution could be made simpler from the fact that I have discovered that the file that I want to identify and open is always the last file in the list in that folder

Probably yes. However, I would stick with this as it is independent of the file postion in the folder, and will be more reusable.

Let me know how it works out.
-DWildman

Re: Open CSV Files By Date

Hmmm - It works fine for me.

Is the workbook that contains the code in the same folder as your .csv files?

Do all of your file names end in .csv?

Re: Rearrange Column To Row Based On Criteria

Hmmm - How were you planning on having tens of thousands of values span one row to begin with?

Re: Rearrange Column To Row Based On Criteria

Use a pivot table[hr]*[/hr] Auto Merged Post;[dl]*[/dl]See example

Re: Update Worksheet Column Number After Removing Row From A Userform

Scorp,

How is your actual spreadsheet set up?

If the plan numbers will always be relative to the row numbers then you can sub the plan numbers with a simple worksheet formula to keep them updated when you delete a row.

For example, say column A is your Plan# column. If the numbers always start at 1 (in A2) and are sequential...then you could use something like =ROW() - 1.

If this is not clear then perhaps you could post an example

Re: Open CSV Files By Date

Leif,

This sub needs to be in a workbook that is in the same directory as all your .CSV files. It loops through all .CSV file in said directory, and the variable sNewest will hold the name of the most recently modified .CSV file.

Sub Recent()


    Dim sFileXls As String
    Dim sNewest As String
    Dim dLstMod As Date
    
    sFileXls = Dir(ThisWorkbook.Path & "\*.csv")
    
    Do While sFileXls <> ""
        If FileDateTime(ThisWorkbook.Path & "\" & sFileXls) > dLstMod Then
            dLstMod = FileDateTime(ThisWorkbook.Path & "\" & sFileXls)
            sNewest = Dir(ThisWorkbook.Path & "\*.csv")
        End If
        sFileXls = Dir()
    Loop
    
    MsgBox "Most recent updated file = " & sNewest
    
End Sub

I used the link below as a reference
http://msdn.microsoft.com/arch…k/html/office09072000.asp

-DWildman