Copying Data From One Range to Another By Averaging the Intersection

[Rick Rothstein]

Dear Mr. Admin,

Looking at this code has made me realize how little I really know about vba. It's like another world out there. Thank you so much for sharing your gift. It works perfectly.

Let's see if we can "blow your mind" then. Here is a non-looping macro that I am pretty sure does what Admin's code does (although it asks you to pick or specify the ranges dynamically as opposed to making you select them first plus it does not require the two ranges to have the same number of rows)...

Sub AverageRanges()
  Dim FirstRow As Long, LastRow As Long
  Dim AddrA As String, AddrB As String
  Dim RngA As Range, RngB As Range, RowRng As Range
  Set RngA = Application.InputBox("Select Range A", Type:=8) 'Range("C6:F10")
  Set RngB = Application.InputBox("Select Range B", Type:=8) 'Range("I9:L13")
  FirstRow = RngA(1).Row
  LastRow = RngB(1).Offset(RngB.Rows.Count).Row - 1
  AddrA = Intersect(Rows(FirstRow & ":" & LastRow), Columns("C:F")).Address
  AddrB = Intersect(Rows(FirstRow & ":" & LastRow), Columns("I:L")).Address
  Range(AddrA) = Evaluate("IF(" & AddrA & "=""""," & AddrB & ",IF(" & AddrB & _
                          "=""""," & AddrA & ",(" & AddrA & "+" & AddrB & ")/2))")
  Range(AddrA).Replace 0, "", xlWhole
End Sub

Note: I should point out that the code assumes no data exists below the end of Range A or above the beginning of Range B. Hopefully that is how your data is set up (if not, let me know and I will see if I can modify the code to make it ignore data outside of the specified ranges).