Aug 06 2020 11:55 PM
Aug 06 2020 11:55 PM
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.
Aug 07 2020 07:52 AM
@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:
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
Aug 07 2020 08:08 PM - edited Aug 07 2020 10:43 PM
@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.
Aug 07 2020 11:33 PM
@Deleted
Will Table 1 and Table 2 always be the same size?
Aug 07 2020 11:50 PM
@Hans Vogelaar Yes same size
Aug 08 2020 03:21 AM
@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
Aug 08 2020 07:31 AM
@Hans Vogelaar Hi, thanks i pasted the code in my sheet but it is not working.. sheet attched with your code.
Aug 08 2020 08:09 AM
@Deleted
What exactly is the problem? I downloaded your workbook and entered Table 1 and Table 2 in A26. This was the result:
Aug 08 2020 08:28 AM - edited Aug 08 2020 09:20 AM
@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.
Aug 08 2020 09:18 AM
@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,
Aug 08 2020 01:04 PM
Solution@Deleted
Here is the workbook with the updated code.
Aug 08 2020 07:59 PM
@Hans Vogelaar Awesome. Thank u kuddos to u..
Aug 08 2020 08:59 PM
Aug 08 2020 08:59 PM
@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.
Aug 08 2020 10:58 PM
@Deleted
See the attached version.
Aug 09 2020 04:48 AM
@Hans Vogelaar Thanks.. Cheers.. Dude
Aug 09 2020 05:15 AM
Aug 09 2020 05:15 AM
@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.
Aug 09 2020 05:18 AM
@Deleted
Could you attach a new sample workbook?
Aug 09 2020 06:39 AM - edited Aug 09 2020 06:52 AM
@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".
Aug 09 2020 06:51 AM
@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
Aug 08 2020 01:04 PM
Solution