Need macro excel to show data on change of heading

[Deleted]

Hi Experts,

I am looking for vba script wherein if i change the heading in sheet 2 as "Table 1" or Table 2" it should automatically show me data in result table from sheet 1 matching the crietera of " Table 1" or "Table 2" aligning with dates.

Can you pls help me to provide maco vba script excel file. I am attaching sample file.

[#2]

@Deleted 

Your sample output isn't correct - it doesn't match Table 1 and Table 2, and the dates in B30:C30 are in July instead of in August.

But this should do what you want:

• Right-click the sheet tab of Sheet1.
• Select 'View code' from the context menu.
• Copy the code listed below into the worksheet module:

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim r As Long
    Dim c As Long
    Dim v As String
    Dim d As Date
    Dim s As String
    Dim i As Long
    Dim r0 As Long
    Dim c0 As Long
    If Not Intersect(Range("A26"), Target) Is Nothing Then
        Application.ScreenUpdating = False
        Application.EnableEvents = False
        Range("B28:D29").ClearContents
        Select Case Range("A26").Value
            Case "Table 1"
                c0 = 1
            Case "Table 2"
                c0 = 8
        End Select
        For r = 28 To 29
            For c = 2 To 4
                v = Cells(r, 1).Value
                d = Cells(30, c).Value
                s = ""
                i = 0
                For r0 = 3 To 7
                    If Cells(r0, c0 + 4).Value = v And Cells(r0, c0 + 5).Value = d Then
                        i = i + 1
                        s = s & vbLf & i & ". " & Cells(r0, c0 + 2).Value
                    End If
                Next r0
                If s <> "" Then
                    Cells(r, c).Value = Mid(s, 2)
                End If
            Next c
        Next r
        Application.EnableEvents = True
        Application.ScreenUpdating = True
    End If
End Sub

[#3]

@Hans Vogelaar Thank u. this works... though i forgot to mention that my data "Table 1" and "Table 2" keeps on increasing with new columns, new entries and increase dates so i need to accommodate all the data and show in the result table as and when the data gets increased.

Can you pls modify the code and re-send me which works dynamically depending upon the column and rows increased in data table.

[#4]

@Deleted 

Will Table 1 and Table 2 always be the same size?

[#5]

@Hans Vogelaar Yes same size

[#6]

@Deleted 

Here is a more dynamic version.

Private Sub Worksheet_Change(ByVal Target As Range)
    ' Change if you move the cell where you enter Table 1 or Table 2
    Const OutputRow = 26
    Dim r As Long
    Dim c As Long
    Dim s As String
    Dim i As Long
    Dim r0 As Long
    Dim c0 As Long
    Dim m0 As Long
    Dim users As New Collection
    Dim dates As New Collection
    If Not Intersect(Range("A" & OutputRow), Target) Is Nothing Then
        Application.ScreenUpdating = False
        Application.EnableEvents = False
        Range("A" & OutputRow).CurrentRegion.Offset(1).Clear
        Select Case Range("A" & OutputRow).Value
            Case "Table 1"
                c0 = 1
            Case "Table 2"
                c0 = 8
        End Select
        m0 = Cells(2, c0).End(xlDown).Row
        On Error Resume Next
        For r0 = 3 To m0
            users.Add Item:=Cells(r0, c0 + 4).Value, Key:=Cells(r0, c0 + 4).Value
            dates.Add Item:=Cells(r0, c0 + 5).Value, Key:=CStr(Cells(r0, c0 + 4).Value)
        Next r0
        On Error GoTo 0
        For r = 1 To users.Count
            Cells(OutputRow + r + 1, 1).Value = users(r)
        Next r
        For c = 1 To dates.Count
            Cells(OutputRow + 1, c + 1).Value = "Items"
            Cells(OutputRow + users.Count + 2, c + 1).Value = dates(c)
        Next c
        For r = 1 To users.Count
            For c = 1 To dates.Count
                s = ""
                i = 0
                For r0 = 3 To m0
                    If Cells(r0, c0 + 4).Value = users(r) And Cells(r0, c0 + 5).Value = dates(c) Then
                        i = i + 1
                        s = s & vbLf & i & ". " & Cells(r0, c0 + 2).Value
                    End If
                Next r0
                If s <> "" Then
                    Cells(r + OutputRow + 1, c + 1).Value = Mid(s, 2)
                End If
            Next c
        Next r
        Range("A" & OutputRow + 1).Resize(users.Count + 2, dates.Count + 1).Borders.LineStyle = xlContinuous
        Application.EnableEvents = True
        Application.ScreenUpdating = True
    End If
End Sub

[#7]

better

[#8]

@Hans Vogelaar Hi, thanks i pasted the code in my sheet but it is not working.. sheet attched with your code.

[#9]

@Deleted 

What exactly is the problem? I downloaded your workbook and entered Table 1 and Table 2 in A26. This was the result:

[#10]

@Hans Vogelaar Hi, my requirement is little changed

Instead of typing Table 1 or Table 2 in A26 Result column can i type code FR and VG code in A26 and show all data of of respective FR or VG in result table considering irrespective if i add new columns in middle of data table 1 or table 2 or increase rows with more data and keeping intact the original design color of result table as it is.

Can u pls send updated sheet with your updated dynamic code.

[#11]

@Deleted 

You had mentioned that you would add rows, but not that you would add columns.

Currently the code assumes that the tables start in columns A and H. To make that dynamic will take more work,

[#12 · Accepted solution]

@Deleted 

Here is the workbook with the updated code.

[#13]

@Hans Vogelaar Awesome. Thank u kuddos to u..

[#14]

@Hans Vogelaar Hi, one last question if i want to shift Result table in sheet 2 then in code where i need to make changes.

[#15]

@Deleted 

See the attached version.

[#16]

@Hans Vogelaar Thanks.. Cheers.. Dude

[#17]

@Hans Vogelaar Suppose if i want merge table 2 with table 1 in data and want to FR, VG in Result then which line i should change the code also in Date column in some rows in data i have date + time 15-11-2019 07:44:27 how can i split this and show only date.

[#18]

@Deleted 

Could you attach a new sample workbook?

[#19]

@Hans Vogelaar Check workbook in attachment.

I just have now table 1.

i want to show data in sheet 2 in result depending upon the code i select "FR" or "VG" or "DR" no matter how much column and rows i insert or delete in sheet 1 in data table 1.

Also i want to show date in result in sheet 2 and and not date time"06-11-2019 09:50:00".

[#20]

@Deleted 

Here you go. I assumed that Code will remain column A on Sheet1.

Private Sub Worksheet_Change(ByVal Target As Range)
    ' Change if you move the cell where you enter the code
    Const OutputRow = 2
    Dim wsh As Worksheet
    Dim cel As Range
    Dim tbl As Range
    Dim r As Long
    Dim c As Long
    Dim s As String
    Dim i As Long
    Dim r0 As Long
    Dim c0 As Long
    Dim m0 As Long
    Dim u As Long
    Dim d As Long
    Dim t As Long
    Dim users As New Collection
    Dim dates As New Collection
    
    Set cel = Cells(OutputRow, 1) 'Result
    If Not Intersect(cel, Target) Is Nothing Then
        ' Change name of worksheet with the data if needed
        Set wsh = Worksheets("Sheet1")
        c0 = 1
        Set tbl = wsh.Rows(2).Find(What:="User", LookAt:=xlWhole, MatchCase:=False)
        If tbl Is Nothing Then
            MsgBox "User column not found!", vbExclamation
            Exit Sub
        End If
        u = tbl.Column
        Set tbl = wsh.Rows(2).Find(What:="Date", LookAt:=xlWhole, MatchCase:=False)
        If tbl Is Nothing Then
            MsgBox "Date column not found!", vbExclamation
            Exit Sub
        End If
        d = tbl.Column
        Set tbl = wsh.Rows(2).Find(What:="Type", LookAt:=xlWhole, MatchCase:=False)
        If tbl Is Nothing Then
            MsgBox "Type column not found!", vbExclamation
            Exit Sub
        End If
        t = tbl.Column
        Application.ScreenUpdating = False
        Application.EnableEvents = False
        With cel.EntireRow
            .Interior.ColorIndex = xlColorIndexNone
            .Borders.LineStyle = xlLineStyleNone
        End With
        cel.CurrentRegion.Offset(1).Clear
        m0 = wsh.Cells(2, c0).End(xlDown).Row
        On Error Resume Next
        For r0 = 3 To m0
            users.Add Item:=wsh.Cells(r0, u).Value, Key:=wsh.Cells(r0, u).Value
            dates.Add Item:=wsh.Cells(r0, d).Value, Key:=CStr(wsh.Cells(r0, d).Value)
        Next r0
        On Error GoTo 0
        SortCollection users
        For r = 1 To users.Count
            Cells(OutputRow + r + 1, 1).Value = users(r)
        Next r
        SortCollection dates
        With cel.Resize(1, dates.Count + 1)
            .Interior.Color = RGB(0, 176, 80)
            .BorderAround LineStyle:=xlContinuous
        End With
        For c = 1 To dates.Count
            cel.Offset(1, c).Value = "Items"
            cel.Offset(users.Count + 2, c).Value = dates(c)
            If c Mod 2 Then
                cel.Offset(users.Count + 2, c).Interior.Color = RGB(197, 90, 17)
            Else
                cel.Offset(users.Count + 2, c).Interior.Color = RGB(61, 195, 176)
            End If
        Next c
        cel.Offset(2, 1).Resize(users.Count, dates.Count).Interior.Color = RGB(242, 242, 242)
        With cel.Offset(users.Count + 2).Resize(1, dates.Count + 1)
            .Font.Color = vbWhite
            .HorizontalAlignment = xlHAlignCenter
        End With
        For r = 1 To users.Count
            For c = 1 To dates.Count
                s = ""
                i = 0
                For r0 = 3 To m0
                    If wsh.Cells(r0, c0).Value = cel.Value And wsh.Cells(r0, u).Value = users(r) _
                            And wsh.Cells(r0, d).Value = dates(c) Then
                        i = i + 1
                        s = s & vbLf & i & ". " & wsh.Cells(r0, t).Value
                    End If
                Next r0
                If s <> "" Then
                    Cells(r + OutputRow + 1, c + 1).Value = Mid(s, 2)
                End If
            Next c
        Next r
        With cel.Offset(1).Resize(users.Count + 1, dates.Count + 1)
            .Borders.LineStyle = xlContinuous
            .VerticalAlignment = xlVAlignTop
        End With
        cel.Offset(1).Resize(1, dates.Count + 1).Interior.Color = RGB(255, 192, 0)
        With cel.Offset(users.Count + 2)
            .Value = "Date"
            .Interior.Color = RGB(0, 32, 96)
        End With
        Application.EnableEvents = True
        Application.ScreenUpdating = True
    End If
End Sub

Sub SortCollection(col As Collection)
    Dim i As Long
    Dim j As Long
    Dim vTemp As Variant
    For i = 1 To col.Count - 1
        For j = i + 1 To col.Count
            If col(i) > col(j) Then
                vTemp = col(j)
                col.Remove j
                col.Add Item:=vTemp, Key:=CStr(vTemp), Before:=i
            End If
        Next j
    Next i
End Sub