Excel VBA non contiguous range more than 255 characters error [duplicate]

Question

I have code which worked fine. But suddenly when I changed range of cells for copying to another sheet I'm getting the error message "Excel VBA Runtime error '1004' - Method 'Range' of object '_Worksheet' failed". I guess it's related to character limitation. So I tried to split the range to several zones and use "Union" function which then messed order of copied cells. I would really appreciate any help or suggestion.

Option Explicit

Public Sub SaveExpenses() Dim UniqueID(1 To 2) As Variant, arr() As Variant Dim Response As VbMsgBoxResult Dim txtPrompt As String, FirstAddress As String Dim RecordRow As Long, i As Long Dim DataRange As Range, FoundCell As Range, Cell As Range, Zone1 As Range, Zone2 As Range, Zone3 As Range, Zone4 As Range Dim wsDataStorage As Worksheet, wsExpenses As Worksheet

With ThisWorkbook
    Set wsDataStorage = .Worksheets("Data Storage")
    Set wsExpenses = .Worksheets("Expenses")
End With

Set Zone1 = wsExpenses.Range("B3,D3,B8:F8,H8:J8,B9:F9,H9:J9,B10:F10,H10:J10,B11:F11,H11:J11,B12:F12,H12:J12,B13:F13,H13:J13")
Set Zone2 = wsExpenses.Range("B17,C17,E17,H17:J17,B18,C18,E18,H18:J18,B19,C19,E19,H19:J19")
Set Zone3 = wsExpenses.Range("B20,C20,E20,H20:J20,B21,C21,E21,H21:J21,B22,C22,E22,H22:J22")
Set Zone4 = wsExpenses.Range("B23,C23,E23,H23:J23,B24,C24,E24,H24:J24,B25,C25,E25,H25:J25,I14,C27,C34")
Set DataRange = Union(Zone1, Zone2, Zone3, Zone4)
 
 

' Set DataRange = wsExpenses.Range("B3,D3," & _ "B8:F8,H8:J8,B9:F9,H9:J9,B10:F10,H10:J10,B11:F11,H11:J11,B12:F12,H12:J12,B13:F13,H13:J13," & _ "B17,C17,E17,H17:J17,B18,C18,E18,H18:J18,B19,C19,E19,H19:J19," & _ "B20,C20,E20,H20:J20,B21,C21,E21,H21:J21,B22,C22,E22,H22:J22," & _ "B23,C23,E23,H23:J23,B24,C24,E24,H24:J24,B25,C25,E25,H25:J25," & _ "I14,C27,C34")

    'check ID values entered
    For i = 1 To 2
        UniqueID(i) = DataRange.Areas(i)
        If Len(UniqueID(i)) = 0 Then Exit Sub
    Next
 
    'new record
    RecordRow = wsDataStorage.Cells(wsDataStorage.Rows.Count, "B").End(xlUp).Row + 1
    txtPrompt = "Saved"
 
    'check record exists
    Set FoundCell = wsDataStorage.Columns(2).Find(UniqueID(1), LookIn:=xlValues, LookAt:=xlWhole)
    If Not FoundCell Is Nothing Then
        FirstAddress = FoundCell.Address
        Do
            If UCase(FoundCell.Offset(, 1).Value) = UCase(UniqueID(2)) Then
                'inform user
                Response = MsgBox(UniqueID(1) & " " & UniqueID(2) & Chr(10) & _
                "Record Already Exists" & Chr(10) & _
                "Do You Want To OverWrite?", 36, "Record Exists")
                If Response = vbNo Then Exit Sub
                'overwrite record
                RecordRow = FoundCell.Row
                txtPrompt = "Updated"
                Exit Do
            End If
            Set FoundCell = wsDataStorage.Columns(2).FindNext(FoundCell)
            If FoundCell Is Nothing Then Exit Do
        Loop Until FoundCell.Address = FirstAddress
    End If
 
    'size array
    ReDim arr(1 To DataRange.Cells.Count)
    i = 0
    For Each Cell In DataRange.Cells
        i = i + 1
        'non-contiguous form cell values to array
        arr(i) = Cell.Value
    Next Cell
 
    'post arr to range
    wsDataStorage.Range("B" & RecordRow).Resize(, UBound(arr)).Value = arr
 
    'inform user
    MsgBox "Form no. " & UniqueID(1) & " " & UniqueID(2) & " Successfully " & txtPrompt, 64, "Record " & txtPrompt
 

End Sub