Writing to Noncontiguous Ranges with VBA

Mike comments:

I’m wondering if this same Array -> Range approach will work with a non-contiguous range?

For example we have an application at work that needs to write around 400 values into an Excel sheet (it does this via ActiveXObjects from the browser. Yuck, I know). At present it does this in a loop calling .cell(row, column) and setting the value property.

I imagine doing Range(“A1, B10, C15, etc”).value = SOME ARRAY, would be much quicker but I’ve been hunting the web for a while now and haven’t found anyone who has done this. Perhaps it’s just not possible?

There is absolutely, positively no way this would work. Except that it does. I have this

I want to write to A1, A2, and A5 without affecting A3 or A4.

Sub testnocon()
    Dim aWrite(1 To 5, 1 To 1) As Long
    aWrite(1, 1) = 2
    aWrite(2, 1) = 2
    aWrite(5, 1) = 2
    Union(Range(“A1:A2”), Range(“A5”)).Value = aWrite
End Sub

And I get this

It doesn’t matter if I fill aWrite(3,1) or aWrite(4,1). In this example I left them blank. But if I fill them, it still leaves A3:A4 untouched. I didn’t know you could do that.

Posted in Uncategorized

16 thoughts on “Writing to Noncontiguous Ranges with VBA

  1. I don’t think it actually works for arrays, though:

    set r=union([q42],[z99])

    typed at the Immediate window command line just puts 42 in both cells…

  2. Actually, it does something not really desired. If we have different values in the array, as in the code below, the result shows a pattern that I cannot fathom.

    Option Explicit

    Sub testnocon()
        Dim aWrite(1 To 11, 1 To 1) As Long
        aWrite(1, 1) = 2
        aWrite(2, 1) = 3
        aWrite(5, 1) = 4
        aWrite(6, 1) = 5
        aWrite(7, 1) = 6
        aWrite(9, 1) = 7
        aWrite(10, 1) = 8
        aWrite(11, 1) = 9
        Union(Range(“A1:A2”), Range(“A5:a7”), Range(“A9:a11”)).Value = aWrite
        End Sub

    The result is



  3. Ooh, that’s nasty. I guess I was right the first time – not possible. :)

    Oddly, this gives the same answer

    Union(Range(“A1”), Range(“A2”), Range(“A5”), Range(“A6”), Range(“A7”), Range(“A9”), Range(“A10”), Range(“A11”)).Value = aWrite
  4. Using Tushar’s setup, why not just read in the full range, change what you want and write it back out again?

    Sub testnocon2()

    Dim aWrite As Variant

    aWrite = WorksheetFunction.Transpose(Range(“A1:A11?))

    aWrite(1) = 2
    aWrite(2) = 3
    aWrite(5) = 4
    aWrite(6) = 5
    aWrite(7) = 6
    aWrite(9) = 7
    aWrite(10) = 8
    aWrite(11) = 9

    Range(“A1:A11?).Value = WorksheetFunction.Transpose(aWrite)

    End Sub

  5. Results are definitely unreliable. Rick’s approach makes sense, but personally I wouldn’t screw around transforming ranges. I’d just use a second array index, e.g., aWrite(2, 1) = 3.

  6. I’m glad I started reading the comments before I started implementing this code! I had been looking for a solution like this but could find one. I guess I’ll still have to use my work around.

    If the formulas aren’t array formulas wouldn’t this work?

    dim r1 as range
    dim v1 as variant


  7. @Dick,

    Okay, then Transpose the formulas instead of the Values. You can then assign constants or other formulas to a smaller subset of the range and the original formulas will remain intact…

    Sub testnocon2()

    Dim aWrite As Variant

    aWrite = WorksheetFunction.Transpose(Range(“A1:A11?).Formula)

    aWrite(1) = “=SUM(D1:D4)”
    aWrite(2) = “=IF(B1=””””,””Okay””,””Not Okay””)”
    aWrite(5) = 1
    aWrite(6) = 2
    aWrite(7) = “=SUM(D5:D7)”
    aWrite(9) = 3
    aWrite(10) = “=IF(B1=””””,””Okay””,””Not Okay””)”
    aWrite(11) = 4

    Range(“A1:A11?).Formula = WorksheetFunction.Transpose(aWrite)

    End Sub

  8. Strange indeed. Entering:


    from the immediate window shows that when assigning arrays to multi-area ranges the values in the 1st, 3rd, 5th,… areas are returned as if the formula were array-entered into each. However the values in the 2nd, 4th, 6th, … appear to be transposed and either wrap around in the case of multiple columns or repeat if only one single column is used. No idea what should cause this?

    I understand it’s possible to write arrays to ranges more efficiently by calling the xlSet API function via a DLL but have not tried this in practice.

  9. Rick – like fzzz I’m puzzled as to why you do the two transposes.

    Not like you to use 28 key strokes when zero would do, so is there a reason?

  10. I approached with

    Sub tst1()
      [A1:A10] = [IF(isblank(A1:A10),{22;33;44;55;66;77;88;99;10;11},A1:A10)]
    End Sub

    But this removes all the formulae
    So I had to add:

    Sub tst2()
      sq = [A1:A10].Formula
      [A1:A10] = [IF(isblank(A1:A10),{22;33;44;55;66;77;88;99;10;11},A1:A10)]
      For j = 1 To UBound(sq)
        If InStr(sq(j, 1), “=”) = 1 Then [A1:A10].Cells(j) = sq(j, 1)
    End Sub
  11. I recently faced with a sort of this task – I needed to scroll through selected cells of a range (could be a filtered range) and multiply numbers to (-1). Cells with other data types are to remain untouched

    After several attempts I found that two ranges are to be determined: Original non-continuious range (range A) and continious range (range B) that covers entirely range A. Range B is estimated from the boundaries of range A.

    Array is bound to the range B

    Tnen the code runs through each cell of range B and checks its intersction with range A. If so, array’s element is filled with the new estimated value. If not arrays’s element inherits original untouched value

    That it is the basic logic and it works well. The code is enclosed (sorry it is a bit bulky)

    Sub Cells_To_Minus_And_Vise_Versa()

    Dim rngRange As Range               ‘Initial discontinious range
    Dim rngRangeContinious As Range     ‘Final continious range
    Dim lng1stRow As Long               ‘First Row number (of potential continious range)
    Dim byt1stCol As Byte               ‘First Column number (of potential continious range)
    Dim lngLastRow As Long              ‘Last Row number (of potential continious range)
    Dim bytLastCol As Byte              ‘Last Column number (of potential continious range)
    Dim rngArea As Range                ‘Range-segment(s) in initial discontinious range
    Dim intAreaCounter As Integer       ‘Counter of range-segments
    Dim lngRows As Long             ‘Number of rows in final continious range
    Dim bytCols As Byte             ‘Number of columns in final continious range
    Dim lngRow As Long              ‘Number of rows in array
    Dim bytCol As Byte              ‘Number of columns in array
    Dim avarValues() As Variant     ‘Array (initially with no dimensions; for data of any type)
    Dim rngIntersection As Range        ‘Intersection (cell of Final continious range with initial range)
    Dim varValue As Variant             ‘Converted value (of any type) written to array

    On Error GoTo ErrorHandler    ‘ Enable error-handling routine

    ‘Turning off screen updates (speed increasing)
    With Application
       .EnableEvents = False
       .ScreenUpdating = False
    End With

    ‘Visible cells selection (useful for filtered ranges)
    If Application.Union(Selection, Selection).Count > 1 Then Selection.SpecialCells(xlCellTypeVisible).Select

    ‘Shortened range – double selections are omitted
    Set rngRange = Application.Union(Selection, Selection)

    ‘Cycle check in all discontinious areas of the selection
    For Each rngArea In rngRange.Areas
        With rngArea
            ‘First Row
           If lng1stRow = 0 Or lng1stRow > .Row Then
                lng1stRow = .Row
            End If
            ‘Last Row
           If lngLastRow <= .Row + .Rows.Count – 1 Then
                lngLastRow = .Row + .Rows.Count – 1
            End If
            ‘First column
           If byt1stCol = 0 Or byt1stCol > .Column Then
                byt1stCol = .Column
            End If
            ‘Last Column
           If bytLastCol <= .Column + .Columns.Count – 1 Then
                bytLastCol = .Column + .Columns.Count – 1
            End If
            intAreaCounter = intAreaCounter + 1
        End With
    Next rngArea

    ‘Whole range that covers all discontinious ones
    Set rngRangeContinious = Range(Cells(lng1stRow, byt1stCol), Cells(lngLastRow, bytLastCol))

    ‘Counting of rows for array
    With rngRangeContinious
        lngRows = .Rows.Count
        bytCols = .Columns.Count
    End With

    ‘Sizing of array
    ReDim avarValues(1 To lngRows, 1 To bytCols)

    ‘Filling of array
    For lngRow = 1 To lngRows
        For bytCol = 1 To bytCols
            ‘Intersection check
           Set rngIntersection = Application.Intersect(Cells(lng1stRow + lngRow – 1, byt1stCol + bytCol – 1), rngRange)
            If rngIntersection Is Nothing Then ‘Cell is out of initial range then it remains unchanged
               varValue = Cells(lng1stRow + lngRow – 1, byt1stCol + bytCol – 1).Value
                ‘Validation of values
               Select Case VarType(Cells(lng1stRow + lngRow – 1, byt1stCol + bytCol – 1).Value)
                    Case 1 To 6     ‘Numbers
                       varValue = Cells(lng1stRow + lngRow – 1, byt1stCol + bytCol – 1).Value * (-1)
                    Case Else       ‘Others
                       varValue = Cells(lng1stRow + lngRow – 1, byt1stCol + bytCol – 1).Value
                End Select
            End If
            ‘Filling of element of array
           avarValues(lngRow, bytCol) = varValue
        Next bytCol
    Next lngRow
    ‘Filling the selection from array
       ‘Important Check! Is AutoFilter is working or not!
       ‘If it is working then array elements are inserted into the range
       ‘incorrectly (1st element only). So the filter has to be temporarily
       ‘deactivated and then restored
    If Worksheets(ActiveSheet.Name).FilterMode = True Then                  ‘Filter is working
    ‘    ===
       ‘oine workaround created and then disabled
       ‘reason – too slow performance of CustomViews.Show action :(
    ‘    With ActiveWorkbook
    ‘        .CustomViews.Add ViewName:=”TempView”, PrintSettings:=False, _
    ‘        RowColSettings:=True                                            ‘Temporary Custom View is created
    ‘        Worksheets(ActiveSheet.Name).AutoFilterMode = False             ‘AutoFilter is off
    ‘        rngRangeContinious = avarValues                                 ‘Range filling from array
    ‘        .CustomViews(“TempView”).Show                                   ‘Custom View is applied
    ‘        .CustomViews(“TempView”).Delete                                 ‘Custom View is deleted
    ‘    End With
    ‘    ===
           Dim wshWorksheet As Worksheet
            Dim rngFilterRangeAddress As String
            Dim bytFilterNumber As Byte
            Dim bytColumn As Byte
            Dim filterArray()
            Set wshWorksheet = Worksheets(ActiveSheet.Name)     ‘Name of current sheet
           With wshWorksheet.AutoFilter
                rngFilterRangeAddress = .Range.Address          ‘Filtered range
               With .Filters
                    ReDim filterArray(1 To .Count, 1 To 3)      ‘Filter Array
                   For bytFilterNumber = 1 To .Count
                        With .Item(bytFilterNumber)
                            If .On Then
                                filterArray(bytFilterNumber, 1) = .Criteria1
                                Select Case .Operator           ‘Check for presence of Operator or criteria2
                                   Case 3 To 6                 ‘Top selection
                                   Case Empty                  ‘No second criteria
                                   Case Else                   ‘Two criteria are selected
                                       filterArray(bytFilterNumber, 2) = .Operator
                                        filterArray(bytFilterNumber, 3) = .Criteria2
                                End Select
                            End If
                        End With
                End With
            End With
            wshWorksheet.AutoFilterMode = False                 ‘Turn off autofilter
           rngRangeContinious = avarValues                     ‘Range filling from array
           For bytColumn = 1 To UBound(filterArray(), 1)       ‘Restore
               If Not IsEmpty(filterArray(bytColumn, 1)) Then
                    If filterArray(bytColumn, 2) Then
                        wshWorksheet.Range(rngFilterRangeAddress).AutoFilter field:=bytColumn, _
                            Criteria1:=filterArray(bytColumn, 1), _
                                Operator:=filterArray(bytColumn, 2), _
                            Criteria2:=filterArray(bytColumn, 3)
                        wshWorksheet.Range(rngFilterRangeAddress).AutoFilter field:=bytColumn, _
                            Criteria1:=filterArray(bytColumn, 1)
                    End If
                End If
        rngRangeContinious = avarValues                          ‘Range filling from array
    End If

    ‘Turning on screen updates
    With Application
       .EnableEvents = True
       .ScreenUpdating = True
    End With

    ‘Error-handling routine
        If Err.Number = 1004 Then                        ‘Evaluate error number 1004
               MsgBox “Excel standard error # “ & Err.Number & “:” & vbCr & vbCr & Err.Description & _
                vbCr & “============================OR==============================” & _
                vbCr & Chr(5) & ” Try to select less rows in a filtered range.”, vbCritical, “Too many filtered rows”
        End If

    End Sub

  12. Ivan,

    Why couldn’t you just enter the -1 in a random cell, copy it, then paste special multiply to visible cells only?

  13. @Ivan,

    I would agree with zach and do it using Paste Special (Multiply); however, if you found that you did need to use code to perform this action, I believe this much short macro would do the job for you…

    Sub Cells_To_Minus_And_Vise_Versa()
    Dim Cell As Range
    For Each Cell In Selection.SpecialCells(xlCellTypeVisible).SpecialCells(xlCellTypeConstants, xlNumbers)
    Cell.Value = -1 * Cell.Value
    End Sub

    Note: I left out the error-checking code which you could provide if you think there will be more than 8192 discontiguous areas (areas being ranges of contiguous cells) which is a limit for SpecialCells in versions of Excel before XL2010.

  14. Gentlemen,

    An idea with PasteSpecial/Multiply did not come to my mind. You are probably right and it is worth testing on big numbers of ranges (especially when AutoFilter is on)

    Regarding ‘For Each Cell’ construction – I had created more or less similar code long ago (here it is)

    Sub Cells_To_Minus_And_Vise_Versa_old()
    ‘ Macro recorded 26/06/2003’
    Dim rngCell As Range
    For Each cell In Selection
        Select Case VarType(cell.Value)
            Case 1 To 6
            cell.Value = cell.Value * (-1)
        End Select
    End Sub

    The practice showed that this code works rather slowly on big numbers of non-contiguous ranges. Sometimes it took minutes to run through all the cells and update them

    That is why I had to use another approach with arrays and succeeded in end-user performance. The code works with steady speed for any number of ranges

    Besides my particular example is a relative one. Just to demonstrate a way of filling of non-contiguous ranges through array

Posting code? Use <pre> tags for VBA and <code> tags for inline.

Leave a Reply

Your email address will not be published.