Excel VBA kopirovani nesouvisle oblasti s vice nez 255 znaky

Zdravim,
mam v excelu formular, ktery se po vyplneni ukladadata na dalsi list. Pri ukladani jsem chtel zkontrolovat, jestli zaznam s timto ID uz existuje a zeptat se na prepsani. Ale narazim na problem s objemem dat, ktery presahuje 255 znaku. Zkousel jsem to rozdelit na zony pomci “UNION” a potom je spojit, ale to totalne rozhazi poradi. Nevedel by prosim nekdo, jak toto vyresit?

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

‘optional clear form entry
‘DataRange.ClearContents

End Sub