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

 

[Peter_SSs]

Is it Areas related?

I believe that it is.

I'm not sure that I have all the ranges correct but see if you can make use of these. I have assumed that the non-contiguous range is the union of Zones 1-4 as per your code above but on the 'Database' sheet.
The first of these codes should take the values, column-by-column (to preserve the order) from that non-contiguous range and put them into the array then write them to row 1. (A1:FP1)
The second code takes the values from A1:FP1 all at once into the MyAr array and then writes them back into that same non-contiguous range, column-by-column.

Sub NonContiguous_To_Row()
  Dim MyAr As Variant
  Dim Sourcerng As Range, Zone1 As Range, Zone2 As Range, Zone3 As Range, Zone4 As Range
  Dim col As Long, rw As Long, n As Long
  
  With Sheets("Database")
    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 Sourcerng = Union(Zone1, Zone2, Zone3, Zone4)
    ReDim MyAr(1 To Sourcerng.Cells.Count)
    For col = 12 To 30
      Select Case col
        Case 16, 21, 26
        Case Else
          For rw = 12 To 35
            If Not Intersect(Sourcerng, .Cells(rw, col)) Is Nothing Then
              n = n + 1
              MyAr(n) = .Cells(rw, col).Value
            End If
          Next rw
      End Select
    Next col
    .Range("A1").Resize(, n).Value = MyAr
  End With
End Sub

Sub Row_To_NonContiguous()
  Dim MyAr As Variant
  Dim Destinationrng As Range, Zone1 As Range, Zone2 As Range, Zone3 As Range, Zone4 As Range
  Dim col As Long, rw As Long, n As Long
  
  Application.Calculation = xlCalculationManual
  Application.ScreenUpdating = False
  With Sheets("Database")
    MyAr = Range("A1:FP1").Value2
    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)
    For col = 12 To 30
      Select Case col
        Case 16, 21, 26
        Case Else
          For rw = 12 To 35
            If Not Intersect(Destinationrng, .Cells(rw, col)) Is Nothing Then
              n = n + 1
              .Cells(rw, col).Value = MyAr(1, n)
            End If
          Next rw
      End Select
    Next col
  End With
  Application.Calculation = xlCalculationAutomatic
  Application.ScreenUpdating = True
End Sub

 

[Markus71]

Hello Peter, thanks a lot for the code. Seems like you are lightning fast in coding ....

Code1 -> NC 2 Row -> Writes nicely all values in the right chronology in the row
Code2 -> Row 2 NC -> It is not pasting back. Should there be something like: MyAr = Destinationrng?
Thanks Markus

 

[Peter_SSs]

Code2 -> Row 2 NC -> It is not pasting back.

What is it doing?
- Error?
- Writing correct data in wrong cells?
- Writing incorrect data in correct cells?
- Nothing?
- Something else?

 

[Markus71]

What is it doing?
- Error?
- Writing correct data in wrong cells?
- Writing incorrect data in correct cells?
- Nothing?
- Something else?

Hi, it's doing nothing

 

[Peter_SSs]

Hi, it's doing nothing

Try starting a new blank workbook, name the sheet 'Database', enter a few values (say 20 would do) across row 1, put the code in that new workbook and run it.

 

[Akuini]

Another attempt without using Union:

Sub a1172448a()
'https://www.mrexcel.com/board/threads/write-to-a-non-contiguous-range-with-vba.1172448

    Dim i As Long, n As Long
    Dim x, ary
    Dim r As Range
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
  
   
ary = Split("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" _
& ",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", ",")
 
    For Each x In ary
        For Each r In Sheets("A").Range(x)
        i = i + 1
        Sheets("Database").Cells(1, i).Value = r.Value
'        Debug.Print r.Address
        Next
    Next

Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic

End Sub

 

[Markus71]

Nope. The original code from the beginning of this thread is still working, but the order is of course not correct anymore.

Sub Load_Data()
    Dim rCell As Range
    Dim i As Long
    Dim Destinationrng As Range, 
    Dim Zone1 As Range, Zone2 As Range, Zone3 As Range, Zone4 As Range
    
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    
    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]

Nope.

Who are you addressing? When there is more than one active respondent in the thread you need to make that clear.

Edit: Sorry, I see that you posted at about the same time as Akuini so you probably hadn't seen that post.

 

[Peter_SSs]

Let's try to clarify what the second code is supposed to do.
My understanding was that it should take whatever data is in row 1 of 'Database' and put those values into that non-contiguous range as follows
A1 goes to L12
A2 -> L13
A3 -> L14
A4 -> L16
.
.
.
Q1 -> L34
R1 -> L35
S1 -> M13
T1 -> M16
etc

If that is not correct, please clarify.

 

[Markus71]

Another attempt without using Union:

Sub a1172448a()
'https://www.mrexcel.com/board/threads/write-to-a-non-contiguous-range-with-vba.1172448

    Dim i As Long, n As Long
    Dim x, ary
    Dim r As Range
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
 
 
ary = Split("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" _
& ",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", ",")
 
    For Each x In ary
        For Each r In Sheets("A").Range(x)
        i = i + 1
        Sheets("Database").Cells(1, i).Value = r.Value
'        Debug.Print r.Address
        Next
    Next

Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic

End Sub

Thanks Akuini,

Sorry Gents, there was a overlapping. Akuinis thread came, but my browser was not updating that fast.
Akuinis approach works and I'll give it a try, because I assume all my confusion is somehow related to the union function and the order of the elements within.
If I can avoid it, it will be somehow easier for me to understand and I do not have to take care of the areas.

The new workbook approach from Peter did not make a difference, that's why I have posted the original code I was using, which worked, but now the order is weird, because of the areas.

I don't want to consume more of your time on this and do my best to solve it without your help.
But be aware, if I can't get it working, I'll be back !

Thanks a lot. This forum is a superfine institution!
MArkus