Filter data based on a column and calculate average dynamically for all the filtered rows

[sangria11]

I have a table where I need to find the elements present in different samples.
For every sample, the no of iterations is a variable - I can have two rows of sample 1 and 3 rows of sample2 or 5 rows of sample4. the number of columns which are the elements can also be different. I have considered 3 samples and 17 elements in this case.


I need to filter based on the sample. All entries corresponding to sample1 needs to be copied to the next spreadsheet and the average needs to be calculated for the entire row of sample 1 , then sample 2 and so on


I am a beginner in vba and hence the code I used is not able to do it for dynamic range of values.


Also, I can only calculate the average using macro recorder. I am not aware how to combine these two codes into one. I tried to search a lot on this topic




I have included the expected results and my codes as well.


Any help would be much appreciated!!! Thank you

Table: (Data)

Sample	El1	El2	El3	El4	El5	El6	El7	El8	El9	El10	El11	El12	El13	El14	El15	El16	El17
Sample1	393331	1504481	75778	4417	943	123913	1390	7	7	3	0	3	0	3	0	3	7
Sample1	412063	1438405	76769	4454	44147820	129880	1580	22333	3.09E+08	73549450	30502700	3906902	15488000	24554970	18558080	7456669	11010050
Sample2	428819	1371168	67321	3947	43852940	121679	1373	22640	2.95E+08	69845060	27878150	4000339	14100450	22153440	17136190	6752473	9827803
Sample2	424563	1439610	71472	4484	44790560	126363	1350	21676	3.01E+08	69680380	28027090	3559731	14267580	22478890	16818990	6909726	9788499
Sample3	442984	1418608	66124	4571	46818160	103528	940	45648	3.16E+08	75111780	26088990	3618853	14567820	23493420	17066320	7516863	11084680
Sample3	438080	1437939	69390	4801	44814690	104542	863	43491	3.2E+08	75668430	27034060	3533046	15121640	23136970	17178350	7412860	11065210
Sample3	436716	1381712	64563	4671	48130480	106974	1237	55891	3.59E+08	81091740	28725960	3533523	15826380	25076590	19268820	8463176	12399330

<colgroup><col width="64" span="18" style="width:48pt"> </colgroup><tbody>
</tbody>

Expected Results :

Sample1	393331	1504481	75778	4417	943	123913	1390	7	7	3	0	3	0	3	0	3	7
Sample1	412063	1438405	76769	4454	44147820	129880	1580	22333	309360000	73549450	30502700	3906902	15488000	24554970	18558080	7456669	11010050
Average	402697	1471443	76273.5	4435.5	22074382	126896.5	1485	11170	154680003.5	36774727	15251350	1953453	7744000	12277487	9279040	3728336	5505029
Sample2	428819	1371168	67321	3947	43852940	121679	1373	22640	294530000	69845060	27878150	4000339	14100450	22153440	17136190	6752473	9827803
Sample2	424563	1439610	71472	4484	44790560	126363	1350	21676	301350000	69680380	28027090	3559731	14267580	22478890	16818990	6909726	9788499
Average	426691	1405389	69396.5	4215.5	44321750	124021	1361.5	22158	297940000	69762720	27952620	3780035	14184015	22316165	16977590	6831100	9808151
Sample3	442984	1418608	66124	4571	46818160	103528	940	45648	316340000	75111780	26088990	3618853	14567820	23493420	17066320	7516863	11084680
Sample3	438080	1437939	69390	4801	44814690	104542	863	43491	320310000	75668430	27034060	3533046	15121640	23136970	17178350	7412860	11065210
Sample3	436716	1381712	64563	4671	48130480	106974	1237	55891	359420000	81091740	28725960	3533523	15826380	25076590	19268820	8463176	12399330
Average	439260	1412753	66692.33	4681	46587777	105014.7	1013.333	48343.33	332023333.3	77290650	27283003	3561807	15171947	23902327	17837830	7797633	11516407

<colgroup><col span="9"><col><col span="8"></colgroup><tbody>
</tbody>

Sub sorttable()




    Dim j As Long 'row variable


    On Error GoTo Err_Execute


    Dim i As Long


'Start search in row 1 in sheet1
    j = 1


'Column counter for sheet2
   i = 1


  
   
 While Len(Range("A" & CStr(j)).Value) > 0


        If Range("A" & CStr(j)).Value = "Sample1" Then


            Range(Range("A" & CStr(j)), Range("A" & CStr(j)).End(xlToRight)).Select
            Selection.Copy
            Sheets("Sheet2").Select
            Sheet2.Cells(i, 1).Select
            Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
            :=False, Transpose:=False
    ' Debug.Print Cells(j + 1, 1) = "=AVERAGE(A1:C" & j - 1 & ")"   ' This is the line i used to calculate average in between the cells, I guess it is wrong and it gives me error
            'Move counter to next Column
            i = i + 1
            'Go back to Sheet1 to continue searching
            Sheets("Sheet1").Select


        ElseIf Range("A" & CStr(j)).Value = "Sample2" Then


            Range(Range("A" & CStr(j)), Range("A" & CStr(j)).End(xlToRight)).Select
            Selection.Copy
                   Sheets("Sheet2").Select
            Sheet2.Cells(i, 1).Select
            Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
            :=False, Transpose:=False
            'Move counter to next Column
           i = i + 1
           Sheets("Sheet1").Select




        ElseIf Range("A" & CStr(j)).Value = "Sample3" Then


            Range(Range("A" & CStr(j)), Range("A" & CStr(j)).End(xlToRight)).Select
            Selection.Copy
                  Sheets("Sheet2").Select
            Sheet2.Cells(i, 1).Select
            Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
            :=False, Transpose:=False
            'Move counter to next Column
            i = i + 1
            'Go back to Sheet1 to continue searching
            Sheets("Sheet1").Select




        End If


            j = j + 1


      Wend


     
   Application.CutCopyMode = False


   MsgBox "the values have been extracted"


   Exit Sub


Err_Execute:
   MsgBox "Error Occured"


End Sub


[\code]

[code]

Sub test()
'
' Test Macro
' Using macro recorder
'


'
    Rows("1:1").Select
    Selection.Copy
    Sheets("Sheet2").Select
    Rows("1:1").Select
    ActiveSheet.Paste
    Range("A3").Select
    Sheets("Sheet1").Select
    Range("2:2,3:3").Select
    Range("A3").Activate
    Application.CutCopyMode = False
    Selection.Copy
    Sheets("Sheet2").Select
    Rows("3:3").Select
    ActiveSheet.Paste
    Range("B5").Select
    Application.CutCopyMode = False
    Range("A5").Select
    Selection.Style = "Normal 2"
    ActiveCell.FormulaR1C1 = "Average"
    Range("B5").Select
    ActiveCell.FormulaR1C1 = "= AVERAGE(R[-2]C,R[-1]C)"
    Range("E7").Select
    ActiveWindow.SmallScroll Down:=2
    Range("B5").Select
    Selection.AutoFill Destination:=Range("B5:R5"), Type:=xlFillDefault
    Range("B5:R5").Select
    Range("A7").Select
    Sheets("Sheet1").Select
    Rows("4:5").Select
    Selection.Copy
    Sheets("Sheet2").Select
    ActiveSheet.Paste
    Range("A5").Select
    Columns("A:A").EntireColumn.AutoFit
    Application.CutCopyMode = False
    Selection.Copy
    Range("A9").Select
    ActiveSheet.Paste
    Application.CutCopyMode = False
    Selection.AutoFill Destination:=Range("A9:B9"), Type:=xlFillDefault
    Range("A9:B9").Select
    Range("B9").Select
    Selection.ClearContents
    ActiveCell.FormulaR1C1 = "= AVERAGE(R[-2]C,R[-1]C)"
    Range("B9").Select
    Selection.AutoFill Destination:=Range("B9:R9"), Type:=xlFillDefault
    Range("B9:R9").Select
    Range("A11").Select
    Sheets("Sheet2").Select
    Range("A27").Select
    Sheets("Sheet1").Select
    Range("A8:R10").Select
    Selection.Copy
    Sheets("Sheet2").Select
    Range("A11").Select
    ActiveSheet.Paste
    Range("A14").Select
    Application.CutCopyMode = False
    Selection.Style = "Normal 2"
    ActiveCell.FormulaR1C1 = "Average"
    Range("B14").Select
    ActiveCell.FormulaR1C1 = "= AVERAGE(R[-3]C:R[-1]C)"
    Range("B14").Select
    Selection.AutoFill Destination:=Range("B14:R14"), Type:=xlFillDefault
    Range("B14:R14").Select
    Range("A16").Select
End Sub


Sub copy_filtered_data()
' Worksheets("Results").Columns("A:Z").Delete Shift:=xlToLeft
On Error Resume Next
Worksheets("Sheet2").UsedRange.SpecialCells(xlCellTypeVisible).Copy _
Destination:=Worksheets("Results").Range("A1")
End Sub




Option Explicit
 
Sub Filter_Copy()
     
    Dim nextrow As Long
    Dim c As Range, rngCriteria As Range
     
    Worksheets.Add().Name = "Filtered_Data"
     
    Application.ScreenUpdating = False
     
    With Sheet3
        .AutoFilterMode = False
        Set rngCriteria = .Range("A1:A5")
        For Each c In rngCriteria
            nextrow = Worksheets("Filtered_Data").Cells(Rows.Count, "A").End(xlUp).Row
            .Range("A1:B" & .Cells(Rows.Count, "A").End(xlUp).Row).AutoFilter field:=1, Criteria1:="=" & c.Value
            .Range("A1:B" & .Cells(Rows.Count, "A").End(xlUp).Row).Offset(1, 0).SpecialCells(xlCellTypeVisible).Copy _
            Worksheets("Filtered_Data").Range("A" & nextrow + 1)
        Next c
    End With
     
    Application.CutCopyMode = False
    Application.ScreenUpdating = True
     
End Sub






Sub tester()
Dim lr As Long
Dim ws As Worksheet
Dim colno, i, j As Integer ' colno -- is the column on which the filter is present
Dim icol As Long
Dim arr As Variant
Dim header As String
Dim header_row As Integer
Dim rng As Variant


colno = 1
Set ws = Sheets("Sheet1")
lr = ws.Cells(ws.Rows.Count, colno).End(xlUp).Row
header = "A1:Q1"
header_row = ws.Range(header).Cells(1).Row
icol = ws.Columns.Count
ws.Cells(1, icol) = "Unique"
'    For i = 2 To lr
'        If ws.Cells(i, colno) <> "" And Application.WorksheetFunction.Match(ws.Cells(i, colno), ws.Columns(icol), 0) = 0 Then
'        ws.Cells(ws.Rows.Count, icol).End(xlUp).Offset(1) = ws.Cells(i, colno)
'        End If
'    Next
arr = Application.WorksheetFunction.Transpose(ws.Columns(icol).SpecialCells(xlCellTypeConstants))
'    ws.Columns(icol).Clear
   For i = 2 To lr
      ws.Range(header).AutoFilter field:=1
           ' Range(Range("A" & CStr(i)), Range("A" & CStr(i)).End(xlToRight)).Select
            'ws.Range("A1:C7").AdvancedFilter Action = xlFilterCopy, CriteriaRange = ws.Range("A1"), CopyToRange = Sheets("Sheet2").Range("A1"), Unique = False
           Debug.Print AutoFilter.Range.Copy
            Sheets("Sheet2").Select
            Sheet2.Cells(1, i).Select
            Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
            :=False, Transpose:=False
            'Move counter to next Column
            i = i + 1
            ws.Select
    Next
  
            j = j + 1


        Application.CutCopyMode = False
   
        MsgBox "All matching data has been copied."
        ws.AutoFilterMode = False
        ws.Activate
End Sub




[\code]

 

[sangria11]

Sub filtercopy , copy_Filtered data and tester are not part of the codes i am using. I used it to test and unfortunately that got pasted as well

 

[Fazza]

this seems to be like built-in functionality, add subtotals. select a cell in data range and then ALT-D-B
(and ALT-D-B then ALT-R to remove)

can you use that?
if you need on a different sheet, just copy data then do subtotals
hth