Consulting

Results 1 to 5 of 5

Thread: requesting help on restructuring code to work on extracting data w. int color red

  1. #1
    VBAX Mentor
    Joined
    Feb 2016
    Posts
    382
    Location

    requesting help on restructuring code to work on extracting data w. int color red

    Function GetColorText(pRange As Range) As String    'Updateby20141105
        Dim xOut As String
        Dim xValue As String
        Dim i As Long
        xValue = pRange.Text
    
    
        For i = 1 To VBA.Len(xValue)
    
    
            If pRange.Characters(i, 1).Font.Color = vbRed Then
                xOut = xOut & VBA.Mid(xValue, i, 1)
            End If
    
    
        Next
    
    
        GetColorText = xOut
    End Function
    I attached a file that shows data that is colored interior red and other data no interior color. I need the existing code to work with interior color of cell instead of the Font color.

    For eample I want to be able to run macro that would remove the data colored in red from the range A22 to E22 and move them from rows to Column, column J starting at row 22; leaving the remaining uncolored data alone.

    Any help on this is greatly appreciated.
    Sincerely Dennis
    Attached Files Attached Files
    Last edited by estatefinds; 08-09-2018 at 08:23 PM.

  2. #2
    VBAX Mentor
    Joined
    Feb 2016
    Posts
    382
    Location
    I'M trying to accomplish geting macro to return all the values colored red into column G.




    Sub Test2(Target As Range)    Dim R As Range, arr, a
        Dim cel As Variant
         
        Set R = Range("A:E").SpecialCells(2)
        For Each cel In R
            If cel.Interior.ColorIndex = 6 Then
                cel.Interior.ColorIndex = xlNone
            End If
        Next
        
        Set R = Nothing
        
        Set R = Range("A:E").SpecialCells(2)
        For Each cel In R
            If cel.Interior.ColorIndex = 6 Then
                cel.Interior.ColorIndex = xlNone
            End If
        Next
        
        Set al = CreateObject("system.collections.arraylist")
    
    
    
    
        arr = Split(Target, "-")  ' THE SPLIT NEEDS TO BE REMOVED AS IT DOESNT APPLY TO MY CURRENT DATA 
     
        For Each a In arr
            Call DoFind(R, a)
        Next
        
        al.Sort
        Dim k As Long
    
    
        k = WorksheetFunction.Max(5, Cells(Rows.Count, "G").End(xlUp).Row + 1)
        Cells(k, "G").Value = Join(al.toarray, "-")
       
    End Sub
    Last edited by estatefinds; 08-10-2018 at 06:47 AM.

  3. #3
    VBAX Mentor
    Joined
    Feb 2016
    Posts
    382
    Location
    the color index number for the code should be 3

  4. #4
    Like this?
    Sub AAAAA()
    Dim fr As Long, lr As Long, lc As Long, c As Range
    fr = IIf(Len(Range("A1")) <> 0, 1, Range("A1").End(xlDown).Row)
    lr = Cells(Rows.Count, 1).End(xlUp).Row
    lc = Cells(fr, 1).End(xlToRight).Column
    
    
    For Each c In Range(Cells(fr, 1), Cells(lr, lc)).SpecialCells(2)
        If c.Interior.ColorIndex = 3 Then Cells(Rows.Count, 10).End(xlUp).Offset(1) = c.Value
    Next c
    End Sub
    Or if you want to go Column by Column
    Sub AAAAB()
    Dim fr As Long, lr As Long, lc As Long, i As Long, ii As Long
    fr = IIf(Len(Range("A1")) <> 0, 1, Range("A1").End(xlDown).Row)
    lr = Cells(Rows.Count, 1).End(xlUp).Row
    lc = Cells(fr, 1).End(xlToRight).Column
    
    
    For i = 1 To lc
        For ii = fr To lr
            If Cells(ii, i).Interior.ColorIndex = 3 Then Cells(Rows.Count, 10).End(xlUp).Offset(1) = Cells(ii, 1).Value
        Next ii
    Next i
    End Sub
    Last edited by jolivanes; 08-10-2018 at 11:11 PM. Reason: 2nd possibility

  5. #5
    VBAX Mentor
    Joined
    Feb 2016
    Posts
    382
    Location
    Awsome!!! thank you very much!!!!

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts
  •