Update Excel Macro for More Flexibility (Update which Columns to Use)

justearth
justearth used Ask the Experts™
on
Hello,
The code below was in response to this question:
I would like to compute correlation matrices (using CORRELATE) for each group in a worksheet. The correlation matrices should be by group (5,6,7,12,13, or 14) on columns D - H.  Ideally the new sheet would be named with at least the group number.

The code below works specifically on Columns D - H. The data I want to use this on will not always be in D - H. Is there a way to update the macro so that I can 'easily' change what columns should be used to make the correlation matrices?

Thanks,
Cheers,
JE
Sub MakeMatrix()
    
    Dim arr() As Long
    Dim CurrentGroup As Long
    Dim SourceWs As Worksheet
    Dim LastR As Long
    Dim Counter As Long
    Dim DestWs As Worksheet
    
    Set SourceWs = ThisWorkbook.Worksheets("data")
    With SourceWs
        .[a1].Sort Key1:=.[a1], Order1:=xlAscending, Header:=xlYes
        LastR = .Cells(.Rows.Count, 1).End(xlUp).Row
        CurrentGroup = .Cells(2, 1)
        ReDim arr(1 To 3, 1 To 1) As Long
        arr(1, 1) = CurrentGroup
        arr(2, 1) = 2
        For Counter = 3 To LastR
            If .Cells(Counter, 1) <> CurrentGroup Then
                arr(3, UBound(arr, 2)) = Counter - 1
                ReDim Preserve arr(1 To 3, 1 To 1 + UBound(arr, 2)) As Long
                arr(1, UBound(arr, 2)) = .Cells(Counter, 1)
                arr(2, UBound(arr, 2)) = Counter
                CurrentGroup = .Cells(Counter, 1)
            ElseIf Counter = LastR Then
                arr(3, UBound(arr, 2)) = Counter
            End If
        Next
    End With
    
    For Counter = 1 To UBound(arr, 2)
        Set DestWs = ThisWorkbook.Worksheets.Add
        With DestWs
            .Name = "Group " & arr(1, Counter) & " Matrix"
           .[a2:a6] = Application.Transpose(SourceWs.[d1:h1])
           .[b1:f1].Value = SourceWs.[d1:h1].Value
           .Range("b2, c3, d4, e5, f6") = 1
           .[b3].Formula = "=CORREL(Data!D" & arr(2, Counter) & ":D" & arr(3, Counter) & _
                ",Data!E" & arr(2, Counter) & ":E" & arr(3, Counter) & ")"
           .[b4].Formula = "=CORREL(Data!D" & arr(2, Counter) & ":D" & arr(3, Counter) & _
                ",Data!F" & arr(2, Counter) & ":F" & arr(3, Counter) & ")"
           .[b5].Formula = "=CORREL(Data!D" & arr(2, Counter) & ":D" & arr(3, Counter) & _
                ",Data!G" & arr(2, Counter) & ":G" & arr(3, Counter) & ")"
           .[b6].Formula = "=CORREL(Data!D" & arr(2, Counter) & ":D" & arr(3, Counter) & _
                ",Data!H" & arr(2, Counter) & ":H" & arr(3, Counter) & ")"
           .[c4].Formula = "=CORREL(Data!E" & arr(2, Counter) & ":E" & arr(3, Counter) & _
                ",Data!F" & arr(2, Counter) & ":F" & arr(3, Counter) & ")"
           .[c5].Formula = "=CORREL(Data!E" & arr(2, Counter) & ":E" & arr(3, Counter) & _
                ",Data!G" & arr(2, Counter) & ":G" & arr(3, Counter) & ")"
           .[c6].Formula = "=CORREL(Data!E" & arr(2, Counter) & ":E" & arr(3, Counter) & _
                ",Data!H" & arr(2, Counter) & ":H" & arr(3, Counter) & ")"
           .[d5].Formula = "=CORREL(Data!F" & arr(2, Counter) & ":F" & arr(3, Counter) & _
                ",Data!G" & arr(2, Counter) & ":G" & arr(3, Counter) & ")"
           .[d6].Formula = "=CORREL(Data!F" & arr(2, Counter) & ":F" & arr(3, Counter) & _
                ",Data!H" & arr(2, Counter) & ":H" & arr(3, Counter) & ")"
           .[e6].Formula = "=CORREL(Data!G" & arr(2, Counter) & ":G" & arr(3, Counter) & _
                ",Data!H" & arr(2, Counter) & ":H" & arr(3, Counter) & ")"
        End With
    Next
    
    MsgBox "Done"
    
End Sub

Open in new window

je-split-groups-into-worksheets.xlsx
Comment
Watch Question

Do more with

Expert Office
EXPERT OFFICE® is a registered trademark of EXPERTS EXCHANGE®
Commented:
You could use this to get the column letter(s) you need

sColLetter1 = InputBox("Type in column letter", "Type in column letter", "D")

Author

Commented:
bogunit:
Could you provide some help with implementing this code?
sColLetter1 = InputBox("Type in column letter", "Type in column letter", "D")

Open in new window


Would this go in the 'range' part of the current code?
.Range("b2, c3, d4, e5, f6") = 1

Open in new window


Thanks again,
Cheers,
JE
Hello,
In an attempt to answer only a part of the above question I asked another, less specific one here:
http://www.experts-exchange.com/Software/Office_Productivity/Office_Suites/MS_Office/Excel/Q_27044092.html

Which ended up answering the whole question.

Thanks,
JE
Sub MakeMatrix()
    
    Dim arr() As Long
    Dim CurrentGroup As Long
    Dim SourceWs As Worksheet
    Dim LastR As Long
    Dim Counter As Long
    Dim DestWs As Worksheet
    
    Set SourceWs = ThisWorkbook.Worksheets("data")
    With SourceWs
        .[a1].Sort Key1:=.[a1], Order1:=xlAscending, Header:=xlYes
        LastR = .Cells(.Rows.Count, 1).End(xlUp).Row
        CurrentGroup = .Cells(2, 1)
        ReDim arr(1 To 3, 1 To 1) As Long
        arr(1, 1) = CurrentGroup
        arr(2, 1) = 2
        For Counter = 3 To LastR
            If .Cells(Counter, 1) <> CurrentGroup Then
                arr(3, UBound(arr, 2)) = Counter - 1
                ReDim Preserve arr(1 To 3, 1 To 1 + UBound(arr, 2)) As Long
                arr(1, UBound(arr, 2)) = .Cells(Counter, 1)
                arr(2, UBound(arr, 2)) = Counter
                CurrentGroup = .Cells(Counter, 1)
            ElseIf Counter = LastR Then
                arr(3, UBound(arr, 2)) = Counter
            End If
        Next
    End With
    
    For Counter = 1 To UBound(arr, 2)
        Set DestWs = ThisWorkbook.Worksheets.Add
        With DestWs
            .Name = "Group " & arr(1, Counter) & " Matrix"
           .[a2:a6] = Application.Transpose(SourceWs.[d1:h1])
           .[b1:f1].Value = SourceWs.[d1:h1].Value
           .Range("b2, c3, d4, e5, f6") = 1
           .[b3].Formula = "=CORREL(Data!D" & arr(2, Counter) & ":D" & arr(3, Counter) & _
                ",Data!E" & arr(2, Counter) & ":E" & arr(3, Counter) & ")"
           .[b4].Formula = "=CORREL(Data!D" & arr(2, Counter) & ":D" & arr(3, Counter) & _
                ",Data!F" & arr(2, Counter) & ":F" & arr(3, Counter) & ")"
           .[b5].Formula = "=CORREL(Data!D" & arr(2, Counter) & ":D" & arr(3, Counter) & _
                ",Data!G" & arr(2, Counter) & ":G" & arr(3, Counter) & ")"
           .[b6].Formula = "=CORREL(Data!D" & arr(2, Counter) & ":D" & arr(3, Counter) & _
                ",Data!H" & arr(2, Counter) & ":H" & arr(3, Counter) & ")"
           .[c4].Formula = "=CORREL(Data!E" & arr(2, Counter) & ":E" & arr(3, Counter) & _
                ",Data!F" & arr(2, Counter) & ":F" & arr(3, Counter) & ")"
           .[c5].Formula = "=CORREL(Data!E" & arr(2, Counter) & ":E" & arr(3, Counter) & _
                ",Data!G" & arr(2, Counter) & ":G" & arr(3, Counter) & ")"
           .[c6].Formula = "=CORREL(Data!E" & arr(2, Counter) & ":E" & arr(3, Counter) & _
                ",Data!H" & arr(2, Counter) & ":H" & arr(3, Counter) & ")"
           .[d5].Formula = "=CORREL(Data!F" & arr(2, Counter) & ":F" & arr(3, Counter) & _
                ",Data!G" & arr(2, Counter) & ":G" & arr(3, Counter) & ")"
           .[d6].Formula = "=CORREL(Data!F" & arr(2, Counter) & ":F" & arr(3, Counter) & _
                ",Data!H" & arr(2, Counter) & ":H" & arr(3, Counter) & ")"
           .[e6].Formula = "=CORREL(Data!G" & arr(2, Counter) & ":G" & arr(3, Counter) & _
                ",Data!H" & arr(2, Counter) & ":H" & arr(3, Counter) & ")"
        End With
    Next
    
    MsgBox "Done"
    
End Sub

Open in new window

Author

Commented:
This is the correct code from the referenced question:
Sub MakeMatrix()
    
    Dim arr() As Long
    Dim CurrentGroup As Long
    Dim SourceWs As Worksheet
    Dim LastR As Long
    Dim Counter As Long
    Dim DestWs As Worksheet
    Dim columnList As Variant
    Dim colNumbers As Variant
    
    columnList = Array("AREA1", "AREA2", "AREA3", "AREA4", "AREA5", "AREA6")
    
    ReDim colNumbers(UBound(columnList))
    Set SourceWs = ThisWorkbook.Worksheets("data")
    With SourceWs
        cnum = 0
        For i = 1 To .Cells(1, .Columns.Count).End(xlToLeft).Column
            If IsInArray(.Cells(1, i), columnList) Then
                colNumbers(cnum) = i
                cnum = cnum + 1
            End If
        Next i
        .[a1].Sort Key1:=.[a1], Order1:=xlAscending, Header:=xlYes
        LastR = .Cells(.Rows.Count, 1).End(xlUp).Row
        CurrentGroup = .Cells(2, 1)
        ReDim arr(1 To 3, 1 To 1) As Long
        arr(1, 1) = CurrentGroup
        arr(2, 1) = 2
        For Counter = 3 To LastR
            If .Cells(Counter, 1) <> CurrentGroup Then
                arr(3, UBound(arr, 2)) = Counter - 1
                ReDim Preserve arr(1 To 3, 1 To 1 + UBound(arr, 2)) As Long
                arr(1, UBound(arr, 2)) = .Cells(Counter, 1)
                arr(2, UBound(arr, 2)) = Counter
                CurrentGroup = .Cells(Counter, 1)
            ElseIf Counter = LastR Then
                arr(3, UBound(arr, 2)) = Counter
            End If
        Next
    End With
    
    For Counter = 1 To UBound(arr, 2)
        Set DestWs = ThisWorkbook.Worksheets.Add
        With DestWs
            .Name = "Group " & arr(1, Counter) & " Matrix"
            .Range(.Cells(2, 1), .Cells(UBound(columnList) + 2, 1)).Value = Application.Transpose(columnList)
            .Range(.Cells(1, 2), .Cells(1, UBound(columnList) + 2)).Value = columnList
            For i = 2 To UBound(columnList) + 2
                .Cells(i, i) = 1
                For j = i + 1 To UBound(columnList) + 2
                    .Cells(j, i).Formula = "=CORREL(Data!R" & arr(2, Counter) & "C" & colNumbers(i - 2) & ":R" & arr(3, Counter) & "C" & colNumbers(i - 2) & ",Data!R" & arr(2, Counter) & "C" & colNumbers(j - 2) & ":R" & arr(3, Counter) & "C" & colNumbers(j - 2) & ")"
                Next j
            Next i
        End With
    Next
    
    MsgBox "Done"
    
End Sub

Public Function IsInArray(FindValue As Variant, arrSearch As Variant) As Boolean
    On Error GoTo LocalError
    If Not IsArray(arrSearch) Then Exit Function
    IsInArray = InStr(1, vbNullChar & Join(arrSearch, vbNullChar) & vbNullChar, vbNullChar & FindValue & vbNullChar) > 0
    
    Exit Function
    
LocalError:
    'Justin (just in case)
End Function

Open in new window

Author

Commented:
Thanks for the suggestion.

Do more with

Expert Office
Submit tech questions to Ask the Experts™ at any time to receive solutions, advice, and new ideas from leading industry professionals.

Start 7-Day Free Trial