Page 1 of 2 12 LastLast
Results 1 to 10 of 11

Thread: Copying Data From One Range to Another By Averaging the Intersection

  1. #1
    Junior Member SDruley's Avatar
    Join Date
    Nov 2012
    Posts
    23
    Rep Power
    0

    Wink Copying Data From One Range to Another By Averaging the Intersection


  2. #2
    Administrator Admin's Avatar
    Join Date
    Mar 2011
    Posts
    1,123
    Rep Power
    10
    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
    Cheers !

    Excel Range to BBCode Table
    Use Social Networking Tools If You Like the Answers !

    Message to Cross Posters

    @ Home - Office 2010/2013/2016 on Win 10 (64 bit); @ Work - Office 2016 on Win 10 (64 bit)

  3. #3
    Junior Member SDruley's Avatar
    Join Date
    Nov 2012
    Posts
    23
    Rep Power
    0
    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

  4. #4
    Forum Guru Rick Rothstein's Avatar
    Join Date
    Feb 2012
    Posts
    662
    Rep Power
    13
    Quote Originally Posted by SDruley View Post
    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).
    Last edited by Rick Rothstein; 11-27-2012 at 01:35 AM.

  5. #5
    Senior Member
    Join Date
    Jun 2012
    Posts
    337
    Rep Power
    13
    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

  6. #6
    Forum Guru Rick Rothstein's Avatar
    Join Date
    Feb 2012
    Posts
    662
    Rep Power
    13
    Quote Originally Posted by snb View Post
    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).

  7. #7
    Junior Member SDruley's Avatar
    Join Date
    Nov 2012
    Posts
    23
    Rep Power
    0
    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

  8. #8
    Senior Member
    Join Date
    Jun 2012
    Posts
    337
    Rep Power
    13
    @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
    Last edited by snb; 11-27-2012 at 04:32 PM.

  9. #9
    Junior Member SDruley's Avatar
    Join Date
    Nov 2012
    Posts
    23
    Rep Power
    0
    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



    Quote Originally Posted by snb View Post
    @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

  10. #10
    Forum Guru Rick Rothstein's Avatar
    Join Date
    Feb 2012
    Posts
    662
    Rep Power
    13
    Quote Originally Posted by snb View Post
    @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.

    Quote Originally Posted by snb View Post
    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).

Similar Threads

  1. Intersection of Overlapping Ranges:Space Operator
    By Transformer in forum Tips, Tricks & Downloads (No Questions)
    Replies: 0
    Last Post: 05-17-2013, 12:32 AM
  2. Copying formulas while keeping formating
    By Bradh in forum Excel Help
    Replies: 1
    Last Post: 12-02-2012, 11:32 AM
  3. Combining data of Two Array or Range
    By princ_wns in forum Excel Help
    Replies: 5
    Last Post: 10-01-2012, 06:52 PM
  4. copying data from multiple workbooks into another
    By rahulcoolz99 in forum Excel Help
    Replies: 1
    Last Post: 08-22-2012, 09:19 PM
  5. Formatting Problem while copying data
    By princ_wns in forum Excel Help
    Replies: 3
    Last Post: 04-03-2012, 07:18 PM

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts
  •