Write to a non contiguous range with VBA

[Markus71]

Dear Users,

I am almost new to VB and I have been out there every night, since days, exploring the web to find a solution to write a range of horzizontal data to a multiple range of non contiguous cells.
After a while I had figured out, how to fill an array with the sourcerange, but pasting to the destinationrange which consists of contigous cells resulted always in the situation, that only the first entry of the array showed up in the destination range. Now, I have found a thread here, which helped me to construct a solution. The thread was >2000days old and the board recommended to start a new threat. Here I am.
Having said that, the solution I have now, works somehow, but it is really slow, because of the 2 loops I am using.

Basically I have a row of horizontal data with 344 cells. Due to the limitations in Range length I have splitted the range in 4x86 cells.
I take the 86 values in an array and then loop through the destination range.
I would appreciate if some pro can take a glance at it and provide me some support to make it faster.

Sub Test_Range3()
    Dim Sourcerng, Destinationrng As Range
    Dim rCell, acell As Range
    Dim i, n As Long

    Application.ScreenUpdating = False
    Set Sourcerng = Sheets("Database").Range("A1:CH1")
     n = Sourcerng.Cells.Count
        ReDim MyAr(1 To n)
        n = 1
        For Each acell In Sourcerng
            MyAr(n) = acell.Value
            n = n + 1
        Next acell
    
    i = 1
    Set Destinationrng = Sheets("Database").Range("L12:L14,L16:L20,L22:L26,L28:L30,L34:L35,M13,M16:M20,M29:M30,N13:N14,N16:N19,N22:N26,O13:O14,O16:O19,Q12:Q14,Q16:Q20,Q22:Q26,Q28:Q30,Q34:Q35,R13,R16:R20,R29:R30,S13:S14,S16:S19,S22:S26,T13:T14,T16:T19")
    For Each rCell In Destinationrng
        rCell.Value = MyAr(i)
       i = i + 1
    Next rCell
Application.ScreenUpdating = True
End Sub

 

[Markus71]

Went back to my machine. 0,02s with Version 2

 

[Markus71]

Works. Thank you so much !

Sub Test_Range5()
    
    Dim rCell, r2Cell As Range
    Dim i As Long
    Application.ScreenUpdating = False
 Application.Calculation = xlCalculationManual
    Application.ScreenUpdating = False
     Dim StartTime As Double
    StartTime = Timer
  Sheets("Database").Activate
    i = 1
    
    For Each rCell In Range("L12:L14,L16:L20,L22:L26,L28:L30,L34:L35,M13,M16:M20,M29:M30,N13:N14,N16:N19,N22:N26,O13:O14,O16:O19,Q12:Q14,Q16:Q20,Q22:Q26,Q28:Q30,Q34:Q35,R13,R16:R20,R29:R30,S13:S14,S16:S19,S22:S26,T13:T14,T16:T19")
        rCell.Value = Cells(1, i).Value
        i = i + 1
        Next rCell
    For Each r2Cell In Range("V12:V14,V16:V20,V22:V26,V28:V30,V34:V35,W13,W16:W20,W29:W30,X13:X14,X16:X19,X22:X26,Y13:Y14,Y16:Y19,AA12:AA14,AA16:AA20,AA22:AA26,AA28:AA30,AA34:AA35,AB13,AB16:AB20,AB29:AB30,AC13:AC14,AC16:AC19,AC22:AC26,AD13:AD14,AD16:AD19")
        r2Cell.Value = Cells(1, i).Value
        i = i + 1
    Next r2Cell
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
MsgBox ("run time: " & Format((Timer - StartTime), "#,##0.00") & " milliseconds") 'end timer
End Sub

Do you see any improvement to the code, otherwise I can happily close it as solved

 

[Peter_SSs]

Just in terms of dealing with the character string limit for ranges, you can get all destination cells into a single range variable with this sort of work-around.
It may not help at all with speed but might give you a cleaner, more logical code.

Dim Destinationrng As Range, Zone1 As Range, Zone2 As Range, Zone3 As Range, Zone4 As Range

Set Zone1 = .Range("L12:L14,L16:L20,L22:L26,L28:L30,L34:L35,M13,M16:M20,M29:M30,N13:N14,N16:N19,N22:N26,O13:O14,O16:O19")
Set Zone2 = .Range("Q12:Q14,Q16:Q20,Q22:Q26,Q28:Q30,Q34:Q35,R13, R16:R20,R29:R30,S13:S14,S16:S19,S22:S26,T13:T14,T16:T19")
Set Zone3 = .Range("V12:V14,V16:V20,V22:V26,V28:V30,V34:V35,W13, W16:W20,W29:W30,X13:X14,X16:X19,X22:X26,Y13:Y14,Y16:Y19")
Set Zone4 = .Range("AA12:AA14,AA16:AA20,AA22:AA26,AA28:AA30,AA34:AA35,AB13, AB16:AB20,AB29:AB30,AC13:AC14,AC16:AC19,AC22:AC26,AD13:AD14,AD16:AD19")
Set Destinationrng = Union(Zone1, Zone2, Zone3, Zone4)

 

[Markus71]

Hello Peter, I have tried to Union the ranges before and I opened pandoras box with it, because the union function somehow aggregated the cells and formed different ranges.
I'll try it later, becaue if it works this time, it is much easier to read. Thanks for your proposal, I will try it again.

 

[Markus71]

Thanks to all of you clever people. It works like a charm, even with the union range, which never worked for me before

Sub Test_Range6()
    Dim rCell As Range
    Dim i As Long
    Dim Destinationrng As Range, Zone1 As Range, Zone2 As Range, Zone3 As Range, Zone4 As Range
    
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    
    Sheets("Database").Activate
    
    Set Zone1 = Sheets("Database").Range("L12:L14,L16:L20,L22:L26,L28:L30,L34:L35,M13,M16:M20,M29:M30,N13:N14,N16:N19,N22:N26,O13:O14,O16:O19")
    Set Zone2 = Sheets("Database").Range("Q12:Q14,Q16:Q20,Q22:Q26,Q28:Q30,Q34:Q35,R13, R16:R20,R29:R30,S13:S14,S16:S19,S22:S26,T13:T14,T16:T19")
    Set Zone3 = Sheets("Database").Range("V12:V14,V16:V20,V22:V26,V28:V30,V34:V35,W13, W16:W20,W29:W30,X13:X14,X16:X19,X22:X26,Y13:Y14,Y16:Y19")
    Set Zone4 = Sheets("Database").Range("AA12:AA14,AA16:AA20,AA22:AA26,AA28:AA30,AA34:AA35,AB13, AB16:AB20,AB29:AB30,AC13:AC14,AC16:AC19,AC22:AC26,AD13:AD14,AD16:AD19")
    Set Destinationrng = Union(Zone1, Zone2, Zone3, Zone4)
    
    i = 1
    For Each rCell In Destinationrng
        rCell.Value = Cells(1, i).Value
        i = i + 1
    Next rCell
   
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
End Sub

 

[Peter_SSs]

Glad you have it sorted. Thanks for letting us know.

 

[Markus71]

.... was not able to click two solution as answer, Murthy and your answered my questions in totality

 

[Peter_SSs]

.. was not able to click two solution as answer,

That's fine, you just click the one that best satisfied your enquiry.

 

[Markus71]

Hello one more time .... I tried to update my code vice versa to paste data from an non contigious range to a single row.
The single row was the base for the code we were discussing initially.
Basically I load data from an non contigious range, store it in an horizontal range and later reload it from the horizontal range to the non contigious range.
And here happens what I have told earlier with the union range. The data becomes weird after breaking the first contigious range.
I need to solve this riddle, because I do not have an explanation for it, but I guess that the range is not stored in an particular order inside of the array.
Nuff said, here is the code I am using

Sub Save_Data()
    Dim rCell As Range
    Dim i As Long, n As Long
    Dim Sourcerng As Range, Sourcerng2 As Range
    Dim Zone1 As Range, Zone2 As Range, Zone3 As Range, Zone4 As Range
    Dim Zone5 As Range, Zone6 As Range, Zone7 As Range, Zone8 As Range
  
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
  
    Set Zone1 = Sheets("A").Range("L12:L14,L16:L20,L22:L26,L28:L30,L34:L35,M13,M16:M20,M29:M30,N13:N14,N16:N19,N22:N26,O13:O14,O16:O19")
    Set Zone2 = Sheets("A").Range("Q12:Q14,Q16:Q20,Q22:Q26,Q28:Q30,Q34:Q35,R13, R16:R20,R29:R30,S13:S14,S16:S19,S22:S26,T13:T14,T16:T19")
    Set Zone3 = Sheets("A").Range("V12:V14,V16:V20,V22:V26,V28:V30,V34:V35,W13, W16:W20,W29:W30,X13:X14,X16:X19,X22:X26,Y13:Y14,Y16:Y19")
    Set Zone4 = Sheets("A").Range("AA12:AA14,AA16:AA20,AA22:AA26,AA28:AA30,AA34:AA35,AB13, AB16:AB20,AB29:AB30,AC13:AC14,AC16:AC19,AC22:AC26,AD13:AD14,AD16:AD19")
    Set Zone5 = Sheets("B").Range("L12:L14,L16:L20,L22:L26,L28:L30,L34:L35,M13,M16:M20,M29:M30,N13:N14,N16:N19,N22:N26,O13:O14,O16:O19")
    Set Zone6 = Sheets("B").Range("Q12:Q14,Q16:Q20,Q22:Q26,Q28:Q30,Q34:Q35,R13, R16:R20,R29:R30,S13:S14,S16:S19,S22:S26,T13:T14,T16:T19")
    Set Zone7 = Sheets("B").Range("V12:V14,V16:V20,V22:V26,V28:V30,V34:V35,W13, W16:W20,W29:W30,X13:X14,X16:X19,X22:X26,Y13:Y14,Y16:Y19")
    Set Zone8 = Sheets("B").Range("AA12:AA14,AA16:AA20,AA22:AA26,AA28:AA30,AA34:AA35,AB13, AB16:AB20,AB29:AB30,AC13:AC14,AC16:AC19,AC22:AC26,AD13:AD14,AD16:AD19")
    Set Sourcerng = Union(Zone1, Zone2, Zone3, Zone4)
    Set Sourcerng2 = Union(Zone5, Zone6, Zone7, Zone8)
  
    i = 1
    For Each rCell In Sourcerng
        Sheets("Database").Cells(1, i).Value = rCell.Value
        i = i + 1
    Next rCell
    i = 1
    For Each rCell In Sourcerng2
        Sheets("Database").Cells(1, i).Value = rCell.Value
        i = i + 1
    Next rCell

Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
End Sub

Here is the range it produces. It should be a range 1,2,3 - 344, but in Column D where there should be a 4, it is a 9 and then the rest is weird, too.

Maybe somebody can bring me back on track, because I faced this issue earlier and always worked around it, but increased the overall complexity.
Thanks Markus

 

[Markus71]

View attachment 39743

Observation:
Maybe it's related to my linear thinking, but even with the odd order, if I write the range with the code from this thread back to the non-contigious ranges, it seems to be correct.
Excel does not know the correct order of this range, so it has to be related to the fashion I write it back. Is it Areas related?
However, I would feel much more comfortable if the saved range is in the right order so I can follow up the chronology of the data and provide table headings etc.
What is the missing link?