Copying Data From One Range to Another By Averaging the Intersection

**SDruley** · 11-26-2012, 04:07 AM

**Admin** · 11-26-2012, 11:07 AM

Hi,

Select the two ranges and run the code.

Code:

Sub Average2Range()
    
    Dim r   As Range
    Dim a   As String
    Dim i   As Long
    Dim c   As Long
    Dim v
    
    Set r = Selection
    
    a = r.Address(0, 0)
    
    v = Split(a, ",")
    
    If Range(v(0)).Rows.Count <> Range(v(1)).Rows.Count Then
        MsgBox "Row count must be same"
        Exit Sub
    ElseIf Range(v(0)).Columns.Count <> Range(v(1)).Columns.Count Then
        MsgBox "Column count must be same"
        Exit Sub
    End If
    
    With r.Parent
        For i = 1 To .Range(v(0)).Rows.Count
            For c = 1 To .Range(v(0)).Columns.Count
                .Range(v(0)).Cells(i, c) = Evaluate("iferror(average(" & .Range(v(0)).Cells(i, c).Address(0, 0) & "," & .Range(v(1)).Cells(i, c).Address(0, 0) & "),"""")")
            Next
        Next
    End With
    
End Sub

**SDruley** · 11-26-2012, 03:12 PM

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.

Steve

**Rick Rothstein** · 11-27-2012, 01:24 AM

Originally Posted by SDruley

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)...

Code:

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).

**snb** · 11-27-2012, 03:07 AM

I agree

Code:

Sub M_snb()
  [C9:F10] = [if(C9:F10<>"",if(I9:L10<>"",int((C9:F10+I9:L10)/2),C9:F10),I9:L10)]
End Sub

**Rick Rothstein** · 11-27-2012, 05:34 AM

Originally Posted by snb

I agree

Code:

Sub M_snb()
  [C9:F10] = [if(C9:F10<>"",if(I9:L10<>"",int((C9:F10+I9:L10)/2),C9:F10),I9:L10)]
End Sub

The only problem I have with your submission is the use of those square brackets... they are slower than using Range and Evaluate (not really noticeably so in this particular instance though) and, more importantly, they are totally inflexible... you can't concatenate variables into them so they are only usable when you know for sure your ranges are totally locked down and will never change (which I do not think will be the case for the OP's ultimate use).

**SDruley** · 11-27-2012, 04:05 PM

Rick,

Your code (in red) as it integrates with a snipet of my code. I am so greatful for this intricate and well devised code and the example it sets for the use of Evaluate, Intersect and xlWhole. I appreciate the opportunity to learn so much on a web site that has so many talented contributors.

Code:

Sub Freeze()
Dim Tt As Long
Dim Rb As Integer
Dim FirstRow As Long, LastRow As Long
Dim AddrA As String, AddrB As String
Dim RngA As Range, RngB As Range, RowRng As Range
Application.ScreenUpdating = False
On Error Resume Next
Sheets("INVESTOR INTERFACE").Activate
Application.Calculation = xlCalculationManual
With Sheets("INVESTOR INTERFACE")
    'FREEZE/STORE TICK-CITY DATABASE
    Let Tt = Application.Range("WHERE15").Value
    Let Rb = Application.Range("reachBACK").offset(0, -1).Value
    If Rb > Tt - 3 Then Rb = Tt - 4
        If Rb = 0 Then
        Exit Sub
        End If
    Set RngA = Sheets("INVESTOR INTERFACE").Range(.Cells(Tt, 128).offset(-Rb, 0), .Cells(Tt, 130))
    Set RngB = RngA.offset(0, 13)
    FirstRow = RngB(1).Row
    LastRow = RngA(1).offset(RngA.Rows.Count).Row - 1
    AddrA = Intersect(Rows(FirstRow & ":" & LastRow), Columns("DX:DZ")).Address
    AddrB = Intersect(Rows(FirstRow & ":" & LastRow), Columns("EK:EM")).Address
    Range(AddrB) = Evaluate("IF(" & AddrB & "=""""," & AddrA & ",IF(" & AddrA & _
                          "=""""," & AddrB & ",(" & AddrB & "+" & AddrA & ")/2))")
    Range(AddrB).Replace 0, "", xlWhole
    ' Erase formulas on this passing train so cells don't have to be calculated [35,000 rows]
    If Tt > 12 Then RngA.offset(-11, 0).Resize(24, 3).ClearContents
End With
On Error GoTo 0
Application.Calculation = xlCalculationAutomatic
End Sub

Steve

**snb** · 11-27-2012, 04:08 PM

@Rick
Although the OP did't ask for any flexibility, I think it's the most flexible one:

Code:

Sub M_snb()
  Range("C9:F10").Name = "snb1"
  Range("I9:L10").Name = "snb2"
  
  [snb1] = [if(snb1*snb2>0,int((snb1+snb2)/2),if(snb1&snb2="","",snb1+snb2))]
End Sub

If you 'abhorr' square brackets, use

Code:

Range("snb1") = Evaluate("if(snb1*snb2>0,int((snb1+snb2)/2),if(snb1&snb2="""","""",snb1+snb2))")

@Steve

Avoid activate in VBA.
The use of 'Let' is redundant in VBA.
I tried to incorporate my suggestion into your snippet:

Code:

Sub Freeze()
    Dim Tt As Long
    Dim Rb As Integer
    Tt = Application.Range("WHERE15").Value
    Rb = Application.Range("reachBACK").Offset(0, -1).Value
    
    If Rb > Tt - 3 Then Rb = Tt - 4
    If Rb <> 0 Then
        Application.ScreenUpdating = False
        Application.Calculation = xlCalculationManual
        
        With Sheets("INVESTOR INTERFACE")
            .Cells(Tt - Rb, 128).Resize(Rb, 3).Name = "snb1"
            .Range("snb1").Offset(, 13).Name = "snb2"
            [snb1] = [if(snb1*snb2>0,int((snb1+snb2)/2),if(snb1&snb2="","",snb1+snb2))]
            If Tt > 12 Then .Range("snb1").Offset(-11, 0).Resize(24, 3).ClearContents
        End With
        Application.Calculation = xlCalculationAutomatic
    End If
End Sub

**SDruley** · 11-27-2012, 04:47 PM

snb and Rick,

Just tested snb's latest submission.
Both coding submissions work nicely. Both take about the same amount of time to run and both are clearly brilliant examples that I certainly could not get from anyone else.
snb, thank you for providing an integrated view of your code, very helpful and well done.

Thank you Europe and the United States

Steve

Originally Posted by snb

@Rick
Although the OP did't ask for any flexibility, I think it's the most flexible one:

Code:

Sub M_snb()
  Range("C9:F10").Name = "snb1"
  Range("I9:L10").Name = "snb2"
  
  [snb1] = [if(snb1*snb2>0,int((snb1+snb2)/2),if(snb1&snb2="","",snb1+snb2))]
End Sub

If you 'abhorr' square brackets, use

Code:

Range("snb1") = Evaluate("if(snb1*snb2>0,int((snb1+snb2)/2),if(snb1&snb2="""","""",snb1+snb2))")

@Steve

Avoid activate in VBA.
The use of 'Let' is redundant in VBA.
I tried to incorporate my suggestion into your snippet:

Code:

Sub Freeze()
    Dim Tt As Long
    Dim Rb As Integer
    Tt = Application.Range("WHERE15").Value
    Rb = Application.Range("reachBACK").Offset(0, -1).Value
    
    If Rb > Tt - 3 Then Rb = Tt - 4
    If Rb <> 0 Then
        Application.ScreenUpdating = False
        Application.Calculation = xlCalculationManual
        
        With Sheets("INVESTOR INTERFACE")
            .Cells(Tt - Rb, 128).Resize(Rb, 3).Name = "snb1"
            .Range("snb1").Offset(, 13).Name = "snb2"
            [snb1] = [if(snb1*snb2>0,int((snb1+snb2)/2),if(snb1&snb2="","",snb1+snb2))]
            If Tt > 12 Then .Range("snb1").Offset(-11, 0).Resize(24, 3).ClearContents
        End With
        Application.Calculation = xlCalculationAutomatic
    End If
End Sub

**Rick Rothstein** · 11-27-2012, 08:05 PM

Originally Posted by snb

@Rick
Although the OP did't ask for any flexibility, I think it's the most flexible one:

Code:

Sub M_snb()
  Range("C9:F10").Name = "snb1"
  Range("I9:L10").Name = "snb2"
  
  [snb1] = [if(snb1*snb2>0,int((snb1+snb2)/2),if(snb1&snb2="","",snb1+snb2))]
End Sub

Excellent! I don't know why, but I keep forgetting about using Defined Names for simplification... and yes, that does make it more flexible.

One suggestion though... delete the Defined Names you create after they are no longer needed in the code so they do not get "locked in" when the user saves his/her workbook.

Originally Posted by snb

If you 'abhorr' square brackets, use

Code:

Range("snb1") = Evaluate("if(snb1*snb2>0,int((snb1+snb2)/2),if(snb1&snb2="""","""",snb1+snb2))")

Yes, I know I can do that... as a matter of fact, that is what I did (except for the Defined Names part, of course). Actually, with using Defined Names, I might reconsider by objection to the square bracket (at least as it applies to substituting for the Evaluate function call).