Dynamic range

Hi

How can I define a dynamic range that will depend on the cell value of another sheet?

I want VBA to loop into the first sheet and identify the value of the first cell. Then go to the second sheet, identify all the cells that have the same value and define these cells as the range (cells with similar value are adjacent). Thanks

This is the section I need to change:

 
If z = Worksheets("Datab").Cells(j, 4) Then
    
RangeOfExchange = Worksheets("Datab").Cells(j, 4)

Here is the full script:

Sub Test3()

    Dim i As Integer
    Dim j as Integer
    Dim z As String
    
    Dim iLastRow As Integer 'the last row on Worksheets("Datab") column D
    Dim iLastRowSummaryC As Integer
    Dim sh1 As Worksheet
    Dim sh2 As Worksheet    'the Worksheets("Datab")
    Dim RangeOfExchange As Range
    
        Set sh1 = ActiveWorkbook.Sheets("Summary")
        
        Set sh2 = ActiveWorkbook.Sheets("Datab")
    
        iLastRowSummaryC = sh1.[C9].End(xlDown).Row + 1
        
        iLastRow = sh2.[D2].End(xlDown).Row + 1     'the last row in Worksheets("Datab")
        
        i = 9
    
            Do While i < iLastRowSummaryC     'we loop down to the last row + 1 populated in sheet Summary, Column C (populated by the previous macro)

            z = Worksheets("Summary").Cells(i, 3)

                j = 2
            
                Do While j < iLastRow   'we loop down to the last row
            
                    If z = Worksheets("Datab").Cells(j, 4) Then
    
                    RangeOfExchange = Worksheets("Datab").Cells(j, 4)
                    
                    End If
                    
                    j = j + 1
                    
                    Loop
                    
            i = i + 1
                
            Loop

End Sub

Hi tigeravatar and thank you for your post.

Once I have identified the range I want to sum the values in this range and past the value into another sheet.
I will take a close look at your module and say if it does what I want, if I can adapt it or if I am looking for something different

Your script does the job but given my limited understanding of VBA and the complexity of your code I am struggling to adapt the last part, basically calling a function that will sum the value of all the cells in the various offseted ranges and import the data into the Summary sheet.

The problem lies in calling the function (Compile error: ByRef argument type mismatch)

Hi have highlighted the modifications I have done in your script and I have attached the excel file I am working on.

Here is the module with the code

Sub tgr()

    Dim wsSummary As Worksheet
    Dim wsDatab As Worksheet
    Dim SummaryCell As Range
    Dim rngFound As Range
    Dim rngExchange() As Range
    Dim strFirst As String
    Dim strUnq As String
    Dim rngIndex As Long
    Dim i As Long
'--------------------------------------------------------------------
    Dim j As Integer
    
    Dim iLastRowSummaryC As Integer
    
    Dim sh1 As Worksheet
'=====================================================================
    
    Set wsSummary = Sheets("Summary")
    Set wsDatab = Sheets("Datab")
    
    With wsSummary.Range("C9", wsSummary.Cells(Rows.Count, "C").End(xlUp))
        ReDim rngExchange(1 To Evaluate("Sumproduct((" & .Address(External:=True) & "<>"""")/Countif(" & .Address(External:=True) & "," & .Address(External:=True) & "&""""))"))
        rngIndex = 0
        For Each SummaryCell In .Cells
            If InStr(1, "|" & strUnq & "|", "|" & SummaryCell.Text & "|", vbTextCompare) = 0 And Len(SummaryCell.Text) > 0 Then
                strUnq = strUnq & "|" & SummaryCell.Text
                Set rngFound = wsDatab.Columns("D").Find(SummaryCell.Text, , xlValues, xlWhole)
                If Not rngFound Is Nothing Then
                    rngIndex = rngIndex + 1
                    strFirst = rngFound.Address
                    Set rngExchange(rngIndex) = rngFound
                    Do
                        Set rngExchange(rngIndex) = Union(rngExchange(rngIndex), rngFound)
                        Set rngFound = wsDatab.Columns("D").Find(SummaryCell.Text, rngFound, xlValues, xlWhole)
                    Loop While rngFound.Address <> strFirst
                    Set rngFound = Nothing
                End If
            End If
'-------------------------------------------------------------------
                
                Set sh1 = ActiveWorkbook.Sheets("Summary")
    
                iLastRowSummaryC = sh1.[C9].End(xlDown).Row + 1
            
                    Do While j < iLastRowSummaryC
                
                    Worksheets("Summary").Cells(j, 3) = SumIPVrngExchange(rngExchange)
                    
                    j = j + 1
                    
                    Exit Do
                    
                    Loop
                    
'=====================================================================
                    
        Next SummaryCell

    End With
    
    For i = 1 To rngIndex
        rngExchange(i).Parent.Select
        rngExchange(i).Select
        MsgBox "Defined range for cells containing: " & Split(Mid(strUnq, 2), "|")(i - 1) & Chr(10) & _
               "rngExchange(" & i & ") = " & "'" & wsDatab.Name & "'!" & rngExchange(i).Address
    Next i
    
    Set wsSummary = Nothing
    Set wsDatab = Nothing
    Erase rngExchange
    
End Sub

Module with the function:

Function SumIPVrngExchange(rngExchange As Range) As Double

    Dim cell As Range
    Dim sumTheCells As Double
 
        For Each cell In rngExchange.Offset(0, 1)
    
            sumTheCells = sumTheCells + cell.Value
            
        Next
        
            SumIPVrngExchange = sumTheCells
        
End Function

Works perfectly, thanks a lot!

Here is a way to run the script by calling functions:

Public variables:

Public i As Integer        'the variable to loop down rows on Worksheets("Summary")

Public j As Integer        'the variable to loop down rows on Worksheets("Datab")

Public Areas As Range      'the range in Worksheets("Datab")

Public sh2 As Worksheet    'the Worksheets("Datab")

Public sh1 As Worksheet     'the Worksheets("Summary")

Public iLastRow As Integer 'the last row on Worksheets("Datab") [column D]

The module:

Sub Test6()

    Dim ExchangeReference As String     'The name of the exchanges on "Summary"
    
    Dim LastRowinSummary As Integer     'The last row in "Summary"

        LastRowinSummary = Worksheets("Summary").Cells(9, 3).End(xlDown).Row
        'LastRowinSummary will be the row number of the last row in sheet "Summary" column C
        
            i = 9
            j = 2
        
                Do While i < LastRowinSummary + 1
            
                 ExchangeReference = Worksheets("Summary").Cells(i, 3)
        
                        Worksheets("Summary").Cells(i, 4) = SumOfExchanges(ExchangeReference)
        
                i = i + 1
                
                Loop

End Sub

The function:

Function SumOfExchanges(ExchangeReference As String) As Double

    Dim m As Integer                'Will be used to define the number of times we want to loop to sum all data
    Dim LastRowinDatab As Integer   'The last row in "Datab"

    Dim FirstCell As Integer        'First cell of the range in "Datab"
    Dim LastCell As Integer         'Last Cell of the range in "Datab"

    Dim dIPVImpact As Double        'The sum of values in column IPVImpact
    
        LastRowinDatab = Worksheets("Datab").Cells(2, 4).End(xlDown).Row
        'LastRowinDatab will be the row number of the last row in sheet "Datab" column D
        
            Do While j < LastRowinDatab + 1
              
                If Worksheets("Datab").Cells(j, 4).Value = ExchangeReference Then
                
                FirstCell = j
            
            Exit Do
            
                End If
            j = j + 1
            
            Loop
                
                    Do While j < LastRowinDatab + 1
    
                        If Worksheets("Datab").Cells(j, 4) = ExchangeReference And Worksheets("Datab").Cells(j + 1, 4) <> ExchangeReference Then
                        
                        LastCell = Worksheets("Datab").Cells(j, 4).Row
                        'Had to use the ".Row" method in order to differentiate from the previous loop
                    Exit Do
                    
                        End If
                    j = j + 1

                    Loop

                            For m = FirstCell To LastCell
                    
                            dIPVImpact = dIPVImpact + Worksheets("Datab").Cells(m, 17).Value
                            Next
    
                            SumOfExchanges = dIPVImpact

End Function