Posts by CodeNerd

CodeNerd · Aug 11th 2017

I am creating a macro for merging multiple cells in column C based on the merged cells in column A. While doing this I want to retain all the values along with rich text formatting. For example if column A1:A3 is merged, I want to merge column C1:C3 while retaining all text in the cells with rich text formatting. I have created the code below and not sure how to proceed further. I could use some help here. Thanks.

Code

Sub mergingcells()[/COLOR]
Dim rng As Range
Dim rng1 As Range
Dim i As Integer, j As Integer, k As Integer, l As Integer
Dim c As Long
Dim lastrow As Long
Dim asd As String


With ActiveSheet
lastrow = Range("A1").SpecialCells(xlCellTypeLastCell).Row
End With


c = 3
Range("C3").Select
For k = 3 To lastrow
Range("c" & c).Select
i = Range("A" & c).MergeArea.Rows.count
j = c + i - 1


    asd = ""
    For l = c To j


            Range("C" & l).Copy
            Range("C" & c).PasteSpecial Paste:=xlPasteAll
            asd = asd & " " & Range("c" & l)
    Next


    Range("c" & c) = asd




    Range("A" & c, "A" & j).Copy
    Range("C" & c).Select
    Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
    SkipBlanks:=False, Transpose:=False
    Application.CutCopyMode = False
    c = c + i


    Next
End Sub

Display More

CodeNerd · Mar 2nd 2017

Re: VBA to delete entire row if cell matches the exact whole word

Hi Jaslake,

I have attached the sample files as you requested. In the attached excel except 4th and 5th row I want everything else to get deleted. So, whatever cell that contains the word "test" or "tst" needs to get deleted.

CodeNerd · Mar 1st 2017

Re: VBA to delete entire row if cell matches the exact whole word

Hi Jaslake

No luck... It's still removing the word "latest" also.

Quote from jaslake;786837

Hi CodeNerd

Perhaps remove the Wildcard from in front of *test* becoming test*

CodeNerd · Mar 1st 2017

Hi All,
Currently I am using the below code to delete the entire row if the mentioned strings matches in the cell value. I need a modification whereas, the row needs to be deleted if the cell matches the exact word.

For example: If column B consist words like "test" and "latest" the code only needs to delete the word "test" leaving "latest".

Thanks.

Code

strWords = "zz,*test*,tst"    For lng = LBound(Split(strWords, ",")) To UBound(Split(strWords, ","))
    Do
    On Error Resume Next
    rng.EntireRow.Delete
    Set rng = Cells.Find(What:=Split(strWords, ",")(lng), LookAt:=xlPart, MatchCase:=True)
    Err.Clear: On Error GoTo 0
    Loop Until rng Is Nothing
    Next lng

CodeNerd · Feb 28th 2017

Hi Guys,

I am using below code to validate URL's on a excel and highlight the cell color respective of the validation. In this code for both 404 error page and redirection the cell is getting highlighted in dark grey. But, I need to change different color for redirection alone.

Since, I am very new to VBA couldn't able to figure it out myself. I have googled and combined this code so far.

Can somebody help please?

Thanks in Advance.

Code

Sub Validate_URLs_on_this_sheet()    Dim tgtSheet As Worksheet
    Set tgtSheet = ActiveWorkbook.ActiveSheet
    ValidateURLs tgtSheet
End Sub




Private Sub ValidateURLs(tgtSheet)
    Dim tgtLastRow, tgtRowCount, validURL As Integer
    Dim workURL As String




    'Get Last Row of entries - Last Row of data in target sheet
    tgtLastRow = tgtSheet.Cells.Find("*", LookIn:=xlValues, SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
    
    'init tgtRowCount as second row (header is first row)
    tgtRowCount = 2
    
    'loop through each row in sheet
    Do While tgtRowCount <= tgtLastRow
        'if not validated yet (not colored), validate this row's URL
        If tgtSheet.Cells(tgtRowCount, 2).Interior.ColorIndex < 0 Then
            workURL = tgtSheet.Cells(tgtRowCount, 2).Value
            'check if it's valid
            validURL = URLExists(workURL)
            'if URL is valid
            If validURL = 4 Then
                'color the cell light green
                tgtSheet.Cells(tgtRowCount, 2).Interior.Color = 11073212 '14348258
            'elseif length is too short
            ElseIf validURL = 1 Then
                'color the cell light grey
                tgtSheet.Cells(tgtRowCount, 2).Interior.Color = 14277081
            'elseif no length returned, and not chunked - manual check - something wrong?
            ElseIf validURL = 0 Then
                'color the cell light red
                tgtSheet.Cells(tgtRowCount, 2).Interior.Color = 4934655
            'else not valid path
            Else
                'color the cell grey
                tgtSheet.Cells(tgtRowCount, 2).Interior.Color = 8421504
            End If
        End If
        
        tgtRowCount = tgtRowCount + 1
    Loop




End Sub




Function URLExists(url As String) As Integer
    'Returns: -1 if invalid URL; 0 if unsure URL; 1 if short URL; 4 if valid URL
    Dim Request As Object
    Dim cl As Long
    Dim te As String
    
    cl = -1
    te = ""
    
    On Error Resume Next
    Set Request = CreateObject("WinHttp.WinHttpRequest.5.1")
    
    With Request
        .SetTimeouts 0, 60000, 60000, 60000
        'Set AT&T Proxy
        .SetProxy 2, "one.proxy.att.com:8080"
            '.SetRequestHeader "Accept-Encoding", "gzip" 'Force gzip to avoid no-length returns
            '.SetRequestHeader "User-Agent", "Mozilla/5.0 (Windows NT 6.1; WOW64; rv:38.0) Gecko/20100101 Firefox/38.0"
        'GET page (can't use HEAD since we want length returned
        .Open "GET", url, False
        'Disable redirects so we capture if one is happening
        .Option(6) = False
        .Send
        'if a valid page status is returned
'MsgBox (.Status)
'MsgBox (.Option(WinHttpRequestOption_URL))
'MsgBox (.GetAllResponseHeaders())
        If .Status = 200 Then
            'get response length - if not present, cl will stay -1
            cl = .GetResponseHeader("Content-Length")
            'get transfer encoding used
            te = LCase(.GetResponseHeader("Transfer-Encoding"))
            'if no length returned
            If cl = -1 Then
                'if transfer is chunked
                If te = "chunked" Then
                    'URL is valid
                    URLExists = 4: Exit Function
                'else should be a single block with length but isn't
                Else
                    'URL is funky - check manual
                    URLExists = 0: Exit Function
                End If
            'if page is zero length
            ElseIf cl = 0 Then
                'URL invalid as nothing actually there
                URLExists = -1: Exit Function
            'if the page is too short to be valid
            ElseIf cl < 40 Then
                'manual check
                URLExists = 1: Exit Function
            'else the URL is valid and long enough to be "real"
            Else
                'URL is valid
                URLExists = 4: Exit Function
            End If
        'else a valid page status was not returned (301, 302, 404, etc.)
        Else
           'URL is invalid
            URLExists = -1: Exit Function
        End If
    End With
    
    'void the object
    Set Request = Nothing
    
MsgBox ("shouldn't be here")
ErrorHandle:
    'should never reach here, but failsafe "manual" value
    URLExists = 0
    '-2147012746 - header not found
End Function

Display More

CodeNerd · Feb 27th 2017

Re: VBA Code to Validate URL and Highlight Cells

Thanks S O, It works perfectly! Once again thanks for your fast response

:yourock:

CodeNerd · Feb 27th 2017

Re: VBA Code to Validate URL and Highlight Cells

Hi SS,
Thanks for your quick response. I am very new to VBA and I was using a code from one of existing sheet I have for this purpose.

The problem with the below code is even though the URL is redirecting the cell will getting highlighted in green. I want the redirected cell to get highlighted in light grey.

Can you able to modify it? Also, I am guessing the line ".Option(WinHttpRequestOption_EnableRedirects) = False" was not supposed to open the redirecting URL but, I believe it is opening the URL by omitting above command.

Code

Function URLExists(url As String) As Integer    'Returns: -1 if invalid URL; 0 if unsure URL; 1 if short URL; 4 if valid URL
    Dim Request As Object
    Dim cl As Long
    Dim te As String
    
    cl = -1
    te = ""
    
    On Error Resume Next
    Set Request = CreateObject("WinHttp.WinHttpRequest.5.1")
    
    With Request
        .SetTimeouts 0, 60000, 60000, 60000
        'Set AT&T Proxy
        .SetProxy 2, "one.proxy.att.com:8080"
            '.SetRequestHeader "Accept-Encoding", "gzip" 'Force gzip to avoid no-length returns
            '.SetRequestHeader "User-Agent", "Mozilla/5.0 (Windows NT 6.1; WOW64; rv:38.0) Gecko/20100101 Firefox/38.0"
        'GET page (can't use HEAD since we want length returned
        .Open "GET", url, False
        'Disable redirects so we capture if one is happening
        .Option(WinHttpRequestOption_EnableRedirects) = False
        .Send
        'if a valid page status is returned
'MsgBox (.Status)
'MsgBox (.Option(WinHttpRequestOption_URL))
'MsgBox (.GetAllResponseHeaders())
        If .Status = 200 Then
            'get response length - if not present, cl will stay -1
            cl = .GetResponseHeader("Content-Length")
            'get transfer encoding used
            te = LCase(.GetResponseHeader("Transfer-Encoding"))
            'if no length returned
            If cl = -1 Then
                'if transfer is chunked
                If te = "chunked" Then
                    'URL is valid
                    URLExists = 4: Exit Function
                'else should be a single block with length but isn't
                Else
                    'URL is funky - check manual
                    URLExists = 0: Exit Function
                End If
            'if page is zero length
            ElseIf cl = 0 Then
                'URL invalid as nothing actually there
                URLExists = -1: Exit Function
            'if the page is too short to be valid
            ElseIf cl < 40 Then
                'manual check
                URLExists = 1: Exit Function
            'else the URL is valid and long enough to be "real"
            Else
                'URL is valid
                URLExists = 4: Exit Function
            End If
        'else a valid page status was not returned (301, 302, 404, etc.)
        Else
           'URL is invalid
            URLExists = -1: Exit Function
        End If
    End With
    
    'void the object
    Set Request = Nothing
    
MsgBox ("shouldn't be here")
ErrorHandle:
    'should never reach here, but failsafe "manual" value
    URLExists = 0
    '-2147012746 - header not found
End Function

Display More

Thanks

CodeNerd · Feb 27th 2017

Hey Guys,

I have a column full of URL's(from cell B2 down). I just need a macro or something to validate each URL and highlight the cell with different color with respective of the results.

If the URL is Valid, I want the cell color to be green.

If the URL redirects, I want the cell color to be yellow.

Finally, If the URL throws a 404 or any other error page, I want the cell color to be grey.

few example URL's are:

Valid One : [TABLE="width: 769"]

[tr]

[TD="class: xl64, width: 769"]https://www.wireless.att.com/b…0-bill-credit-details.jsp ( needs to be green)

Redirected One: [TABLE="width: 769"]

[tr]

[TD="class: xl65, width: 769"]https://www.wireless.att.com/b…ns/200-port-in-credit.jsp (needs to be yellow)

Error Page:[TABLE="width: 769"]

[tr]

[TD="class: xl65, width: 769"]https://www.wireless.att.com/b…/100-bill-credit-July.jsp (needs to be grey)[/TD]

[/tr]

[/TABLE]
[/TD]

[/tr]

[/TABLE]
[/TD]

[/tr]

[/TABLE]

Please help, Thanks in Advance.

Posts by CodeNerd

Vba code to copy rich text formatting along with values from one range to another

VBA to delete entire row if cell matches the exact whole word

VBA to delete entire row if cell matches the exact whole word

VBA to delete entire row if cell matches the exact whole word

VBA Code modification to change cell color for redirected URL

VBA Code to Validate URL and Highlight Cells

VBA Code to Validate URL and Highlight Cells

VBA Code to Validate URL and Highlight Cells