Write Array with Formats

S

Super P

New Member
Joined
May 22, 2021
Messages
28
Office Version
  1. 365
Platform
  1. Windows
Need help from Array VBA expert. Instead of formatting each cell in a range as per code below, is it possible to get this format included in Array so that once it write to back to range it is formatted at the same time of writing?

VBA Code: 
Option Explicit

Sub Write_Array_With_Format()

    Dim xArr, aArr, bArr, sArr(), oArr() As Variant, lRow, i As Long, x, A, B As Double

    With Worksheets("Data")    'set data ranges to array
      lRow = .Cells(Rows.Count, 2).End(xlUp).Row
      xArr = .Range(.Cells(6, 2), .Cells(lRow, 2)).Value2
      aArr = .Range(.Cells(6, 3), .Cells(lRow, 3)).Value2
      bArr = .Range(.Cells(6, 4), .Cells(lRow, 4)).Value2
    End With
    
    ReDim sArr(LBound(xArr, 1) To UBound(xArr, 1), 1 To 1) 'String Array
    
    sArr = Array("x A B", "A x B", "A B x", "x B A", "B x A", "B A x")
    
    sArr = Application.Transpose(sArr)
    
    ReDim oArr(LBound(xArr, 1) To UBound(xArr, 1), 1 To 1) 'Output Array
    
    For i = 1 To UBound(xArr, 1)
    
        x = xArr(i, 1): A = aArr(i, 1): B = bArr(i, 1)
        
        If x > A And x > B And A > B Then
            oArr(i, 1) = sArr(1, 1)
        
        ElseIf x < A And x > B And A > B Then
            oArr(i, 1) = sArr(2, 1)

        ElseIf x < A And x < B And A > B Then
            oArr(i, 1) = sArr(3, 1)

        ElseIf x > A And x > B And A < B Then
            oArr(i, 1) = sArr(4, 1)

        ElseIf x > A And x < B And A < B Then
            oArr(i, 1) = sArr(5, 1)

        ElseIf x < A And x < B And A < B Then
            oArr(i, 1) = sArr(6, 1)
                
        End If

    Next
    
    With Worksheets("Data")
        .Range(.Cells(6, 5), .Cells(lRow, 5)).Value2 = oArr 'write Output Array to Range
        
        For i = 6 To lRow   'Format values
            
            If .Range("E" & i).Value = "x A B" Then
                With .Range("E" & i)
                    With .Characters(1, 1).Font
                        .Color = vbBlue
                    End With
                    With .Characters(3, 3).Font
                        .Underline = True
                        .Color = vbGreen
                    End With
                End With
            
            ElseIf .Range("E" & i).Value = "A x B" Then
                With .Range("E" & i)
                    With .Characters(1, 2).Font
                        .Color = vbGreen
                        .Underline = True
                    End With
                    With .Characters(3, 1).Font
                        .Underline = True
                        .Color = vbBlue
                    End With
                    With .Characters(5, 1).Font
                        .Color = vbGreen
                    End With
                End With
            
            'And so on and so forth.............
            
            End If
        Next
    
    End With
    
End Sub
 

Attachments

  • image_2022-04-20_091347.png
    image_2022-04-20_091347.png
    7.7 KB · Views: 11
  • image_2022-04-20_091415.png
    image_2022-04-20_091415.png
    6.7 KB · Views: 10

Excel Facts

Add Bullets to Range
Select range. Press Ctrl+1. On Number tab, choose Custom. Type Alt+7 then space then @ sign (using 7 on numeric keypad)
Sort by date Sort by votes
short answer, no. (But excel is full of surprises, if somebody else ...)
 
Upvote 0
Whilst I agree that the array cannot store/apply the formatting the code could be modified to address the following ..
Super P said:
Instead of formatting each cell in a range
Click to expand...

Instead of cycling through every single cell of the results and formatting it individually, this code records (while processing the array data) which result cells fall into each category and then formats all the cells in each category at once.

VBA Code: 
Sub Write_Array_With_Format_v2()

  Dim xArr, aArr, bArr, sArr(), oArr() As Variant, lRow, i As Long, x, A, B As Double
  
  'Ranges to store the cells to be formatted
  Dim xAB As Range, AxB As Range  ' & others?
  
  With Worksheets("Data")    'set data ranges to array
    lRow = .Cells(Rows.Count, 2).End(xlUp).Row
    xArr = .Range(.Cells(6, 2), .Cells(lRow, 2)).Value2
    aArr = .Range(.Cells(6, 3), .Cells(lRow, 3)).Value2
    bArr = .Range(.Cells(6, 4), .Cells(lRow, 4)).Value2
    
    'Set initial 'dummy' range cells (removed later)
    Set xAB = .Range("E1")
    Set AxB = .Range("E1")
    ' & others?
  
    ReDim sArr(LBound(xArr, 1) To UBound(xArr, 1), 1 To 1) 'String Array
  
    sArr = Array("x A B", "A x B", "A B x", "x B A", "B x A", "B A x")
    
    sArr = Application.Transpose(sArr)
    
    ReDim oArr(LBound(xArr, 1) To UBound(xArr, 1), 1 To 1) 'Output Array
    
    For i = 1 To UBound(xArr, 1)
    
        x = xArr(i, 1): A = aArr(i, 1): B = bArr(i, 1)
        
        If x > A And x > B And A > B Then
            oArr(i, 1) = sArr(1, 1)
            Set xAB = Union(xAB, .Cells(i + 5, 5))  'Add the result cell to the category range
        
        ElseIf x < A And x > B And A > B Then
            oArr(i, 1) = sArr(2, 1)
            Set AxB = Union(AxB, .Cells(i + 5, 5))  'Add the result cell to the category range

        ElseIf x < A And x < B And A > B Then
            oArr(i, 1) = sArr(3, 1)

        ElseIf x > A And x > B And A < B Then
            oArr(i, 1) = sArr(4, 1)

        ElseIf x > A And x < B And A < B Then
            oArr(i, 1) = sArr(5, 1)

        ElseIf x < A And x < B And A < B Then
            oArr(i, 1) = sArr(6, 1)
                
        End If

    Next i
    
    Application.ScreenUpdating = False
    .Range(.Cells(6, 5), .Cells(lRow, 5)).Value2 = oArr 'write Output Array to Range
       
    'If > 1 cell in xAB range then remove the dummy initial cell and format the rest
    If xAB.Count > 1 Then
      With Intersect(xAB, .Rows("6:" & lRow))
        .Characters(1, 1).Font.Color = vbBlue
        With .Characters(3, 3).Font
          .Underline = True
          .Color = vbGreen
        End With
      End With
    End If
    
    'If > 1 cell in AxB range then remove the dummy initial cell and format the rest
    If AxB.Count > 1 Then
      With Intersect(AxB, .Rows("6:" & lRow))
        .Font.Color = vbGreen
        .Characters(1, 3).Font.Underline = True
        .Characters(3, 1).Font.Color = vbBlue
      End With
    End If
    
    '& other sections?
    
    Application.ScreenUpdating = True
  End With
End Sub
 
Upvote 0
Solution
Peter_SSs said:
Whilst I agree that the array cannot store/apply the formatting the code could be modified to address the following ..


Instead of cycling through every single cell of the results and formatting it individually, this code records (while processing the array data) which result cells fall into each category and then formats all the cells in each category at once.

VBA Code: 
Sub Write_Array_With_Format_v2()

  Dim xArr, aArr, bArr, sArr(), oArr() As Variant, lRow, i As Long, x, A, B As Double
 
  'Ranges to store the cells to be formatted
  Dim xAB As Range, AxB As Range  ' & others?
 
  With Worksheets("Data")    'set data ranges to array
    lRow = .Cells(Rows.Count, 2).End(xlUp).Row
    xArr = .Range(.Cells(6, 2), .Cells(lRow, 2)).Value2
    aArr = .Range(.Cells(6, 3), .Cells(lRow, 3)).Value2
    bArr = .Range(.Cells(6, 4), .Cells(lRow, 4)).Value2
   
    'Set initial 'dummy' range cells (removed later)
    Set xAB = .Range("E1")
    Set AxB = .Range("E1")
    ' & others?
 
    ReDim sArr(LBound(xArr, 1) To UBound(xArr, 1), 1 To 1) 'String Array
 
    sArr = Array("x A B", "A x B", "A B x", "x B A", "B x A", "B A x")
   
    sArr = Application.Transpose(sArr)
   
    ReDim oArr(LBound(xArr, 1) To UBound(xArr, 1), 1 To 1) 'Output Array
   
    For i = 1 To UBound(xArr, 1)
   
        x = xArr(i, 1): A = aArr(i, 1): B = bArr(i, 1)
       
        If x > A And x > B And A > B Then
            oArr(i, 1) = sArr(1, 1)
            Set xAB = Union(xAB, .Cells(i + 5, 5))  'Add the result cell to the category range
       
        ElseIf x < A And x > B And A > B Then
            oArr(i, 1) = sArr(2, 1)
            Set AxB = Union(AxB, .Cells(i + 5, 5))  'Add the result cell to the category range

        ElseIf x < A And x < B And A > B Then
            oArr(i, 1) = sArr(3, 1)

        ElseIf x > A And x > B And A < B Then
            oArr(i, 1) = sArr(4, 1)

        ElseIf x > A And x < B And A < B Then
            oArr(i, 1) = sArr(5, 1)

        ElseIf x < A And x < B And A < B Then
            oArr(i, 1) = sArr(6, 1)
               
        End If

    Next i
   
    Application.ScreenUpdating = False
    .Range(.Cells(6, 5), .Cells(lRow, 5)).Value2 = oArr 'write Output Array to Range
      
    'If > 1 cell in xAB range then remove the dummy initial cell and format the rest
    If xAB.Count > 1 Then
      With Intersect(xAB, .Rows("6:" & lRow))
        .Characters(1, 1).Font.Color = vbBlue
        With .Characters(3, 3).Font
          .Underline = True
          .Color = vbGreen
        End With
      End With
    End If
   
    'If > 1 cell in AxB range then remove the dummy initial cell and format the rest
    If AxB.Count > 1 Then
      With Intersect(AxB, .Rows("6:" & lRow))
        .Font.Color = vbGreen
        .Characters(1, 3).Font.Underline = True
        .Characters(3, 1).Font.Color = vbBlue
      End With
    End If
   
    '& other sections?
   
    Application.ScreenUpdating = True
  End With
End Sub
Click to expand...
@Peter_SSs many thanks.. I will this out.....
 
Upvote 0
You must log in or register to reply here.

Similar threads

J
  • Solved
Filter a listbox containing 12 columns using a single searchbox
Replies
8
Views
274
Anthony47
A
E
  • Question
VBA code Filter by Array has Memory Full error. Please fix the code
Replies
3
Views
268
ISY
I
E
  • Question
Help fix the code Error Out of memory when Variable A >=600,000
Replies
1
Views
469
DanteAmor
DanteAmor
JeffGrant
  • Solved
VBA Code used twice, keeps table formatting on one sheet, but not on the other
Replies
4
Views
298
smozgur
smozgur
JeffGrant
  • Question
Find & Replace is searching whole workbook instead of just the sheet
Replies
7
Views
267
bobsan42
bobsan42

Forum statistics

Threads
1,216,558
Messages
6,131,400
Members
449,648
Latest member
kyouryo

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top