Solved: Populate values multiple times date wise

[Skopweb]

Hello
I have workbook that contains person name and details in the first sheet
The second sheet has date-wise assignment of tasks for the month (there are 3 different tasks)
In the third sheet should display the names (date-wise) and details from the 1st sheets that have been assigned the 3rd task as per 2nd sheet.


Can you help in getting a code to set this up please
:help

Regards
Skopweb

[Simon Lloyd]

Perhaps use Vlookups to get your results.

[Skopweb]

Perhaps use Vlookups to get your results.
Hi Simon
Thanks for the reply.
However, i'm correct vlookup will allow me to get the first match. But there can be instances that task 3 might be assigned to individual for others days of the month.
Hence the names might be repeated for different dates in the 3rd sheet.
A continuous loop would be required for this
Let me know if you have a different opinion

Regards
Skopweb

[Simon Lloyd]

Why not attach a workbook to illustrate your question?

[Skopweb]

Why not attach a workbook to illustrate your question?

Hi Simon
Please refer to the attached workbook.
Sheet "Person Info" has data of 12 persons
Sheet "Task Schedule" has daily tasks assigned to 16 persons (Task 1, Task 2, Task 3, Task 4)
Hence, in the third sheet, i would like to auto populate date-wise details of those 12 persons from "Person Info" and its corresponding task (lets say only Task 3 and Task 4) for those dates.

Regards
Skopweb

[Skopweb]

Can this be possible?

[GTO]

Hi there,

Maybe its just me, but it seems unclear as to what exactly we are populating and based on what? I would suggest showing what the thrid sheet should end up like, and based on what logic or decision of the user.

Marks

[Skopweb]

Dear GTO
Thanks for replying
I have attached the same sheet again with the desired results in Sheet3 (I have shown only for dates 01/01/2011 and 01/02/2011 as example, the same should continue for the entire month)
.. Please refer to the blue cells in Sheet 2. These are Task 3 and Task 4 for those 12 persons that are present in Sheet 1.
Task 3 and Task 4 are also assigned to Person 13 till Person 16, however they should not reflect in Sheet 3 as their names do not show up in Sheet 1.

I hope this will help you to help me out :help

Regards.
Skopweb

[GTO]

Greetings Skopweb,

I opted to include selecting the user IDs one wanter to return data about. I am past hours a bit, so if this meets your needs, but you have a hard time understanding any of the code, feel free to ask.

In a Userform named: frmPicker

Two ListBox Controls, named: lstIDs and lstTasks
Two Command Buttons, named: cmdExecute and cmdCancel

Code:

Option Explicit

Dim DIC As Dictionary
Dim rngTaskPage As Range
Dim aryPersonInfo As Variant

Private Sub cmdCancel_Click()
Unload Me
End Sub

Private Sub cmdExecute_Click()
Dim DIC2 As Object, _
i As Long, _
x As Long, _
y As Long, _
IndexRow As Long, _
lUBnd As Long, _
aryTmp As Variant, _
aryTransposed As Variant, _
aryOutput As Variant, _
rng As Range

Set DIC2 = CreateObject("Scripting.Dictionary")

For i = 0 To lstIDs.ListCount - 1
If lstIDs.Selected(i) Then
DIC2.Item(lstIDs.List(i)) = Empty
End If
Next

DIC.RemoveAll
For i = 0 To lstTasks.ListCount - 1
If lstTasks.Selected(i) Then
DIC.Item(lstTasks.List(i)) = Empty
End If
Next

aryTmp = rngTaskPage.Value
ReDim aryTransposed(1 To 6, 0 To 0)

For x = 2 To UBound(aryTmp, 1)
For y = 2 To UBound(aryTmp, 2)
If DIC2.Exists(aryTmp(1, y)) Then
If DIC.Exists(aryTmp(x, y)) Then
IndexRow = Application.Match(aryTmp(1, y), _
Application.Index(aryPersonInfo, 0, 1), _
0)

ReDim Preserve aryTransposed(1 To 6, 1 To UBound(aryTransposed, 2) + 1)
lUBnd = UBound(aryTransposed, 2)
aryTransposed(1, lUBnd) = aryTmp(x, 1)
aryTransposed(2, lUBnd) = aryPersonInfo(IndexRow, 1)
aryTransposed(3, lUBnd) = aryPersonInfo(IndexRow, 2)
aryTransposed(4, lUBnd) = aryPersonInfo(IndexRow, 3)
aryTransposed(5, lUBnd) = aryPersonInfo(IndexRow, 4)
aryTransposed(6, lUBnd) = aryTmp(x, y)
End If
End If
Next
Next

ReDim aryOutput(1 To UBound(aryTransposed, 2), 1 To 6)

For x = 1 To UBound(aryOutput, 1)
For y = 1 To 6
aryOutput(x, y) = aryTransposed(y, x)
Next
Next

With ThisWorkbook
With .Worksheets.Add(After:=.Worksheets(.Worksheets.Count), Type:=xlWorksheet) _
.Range("A2").Resize(UBound(aryOutput, 1), UBound(aryOutput, 2))

Set rng = ThisWorkbook.Worksheets(.Parent.Name).Range(.Address)
Set rng = rng.Resize(1).Offset(-1)
.Value = aryOutput
.BorderAround , xlMedium, 0
With .Borders(xlInsideVertical)
.LineStyle = xlContinuous
.Weight = xlMedium
.ColorIndex = xlAutomatic
End With
With .Borders(xlInsideHorizontal)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
End With
End With

With rng
With .Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.Weight = xlMedium
.ColorIndex = 0
End With
With .Borders(xlEdgeTop)
.LineStyle = xlContinuous
.Weight = xlMedium
.ColorIndex = 0
End With
With .Borders(xlEdgeRight)
.LineStyle = xlContinuous
.Weight = xlMedium
.ColorIndex = 0
End With
With .Borders(xlInsideVertical)
.LineStyle = xlContinuous
.Weight = xlMedium
.ColorIndex = 0
End With
.Value = Array("Date", "ID", "Name", "Email Address", "Locarion", "Task Number")
.Font.Bold = True
.EntireColumn.AutoFit
End With

Unload Me
End Sub

Private Sub lstIDs_Change()
Call EnableExecute
End Sub

Private Sub lstTasks_Change()
Call EnableExecute
End Sub

Private Function EnableExecute()
Dim _
i As Long, _
x As Long, _
bolIDSelected As Boolean, _
bolTaskSelected As Boolean

For i = 0 To lstIDs.ListCount - 1
If lstIDs.Selected(i) Then
bolIDSelected = True
Exit For
End If
Next

For i = 0 To lstTasks.ListCount - 1
If lstTasks.Selected(i) Then
bolTaskSelected = True
Exit For
End If
Next

If bolIDSelected And bolTaskSelected Then
cmdExecute.Enabled = True
Else
cmdExecute.Enabled = False
End If
End Function

Private Sub UserForm_Activate()
End Sub
Private Sub UserForm_Initialize()
Dim i As Long
Dim lRow As Long, lCol As Long
Dim aryTmp As Variant, CellVal As Variant
Dim lstItem As Variant
Dim bolAdded As Boolean
Dim rngIDs As Range
Dim rngPersonInfo As Range

With Me
.Caption = "Data Filter"
.cmdExecute.Enabled = False
End With

Set rngIDs = RangeFound( _
SearchRange:=Range(shtPersonInfo.Range("B2"), _
shtPersonInfo.Cells(shtPersonInfo.Rows.Count, "B")) _
)
If rngIDs Is Nothing Then
Unload Me
MsgBox "No ID's were found...", vbInformation, vbNullString
End If

Set rngIDs = Range(shtPersonInfo.Range("B2"), rngIDs)
Set rngPersonInfo = rngIDs.Resize(, 4)
aryPersonInfo = rngPersonInfo.Value
lstIDs.List = rngIDs.Value

Set rngTaskPage = RangeFound( _
SearchRange:=Range( _
shtTaskSchedule.Range("B3"), _
shtTaskSchedule.Cells(shtTaskSchedule.Rows.Count, shtTaskSchedule.Columns.Count) _
) _
)
If rngTaskPage Is Nothing Then
Unload Me
MsgBox "No Tasks were listed on " & shtTaskSchedule.Name & "!", _
vbInformation, _
vbNullString
End If

lRow = rngTaskPage.Row
Set rngTaskPage = Nothing
Set rngTaskPage = _
RangeFound( _
SearchRange:=Range(shtTaskSchedule.Range("B3"), _
shtTaskSchedule.Cells(shtTaskSchedule.Rows.Count, _
shtTaskSchedule.Columns.Count) _
), _
SearchRowCol:=xlByColumns _
)
lCol = rngTaskPage.Column
Set rngTaskPage = Range(shtTaskSchedule.Range("B3"), shtTaskSchedule.Cells(lRow, lCol))
aryTmp = rngTaskPage.Value

Set rngTaskPage = rngTaskPage _
.Resize(rngTaskPage.Rows.Count + 1, rngTaskPage.Columns.Count + 1) _
.Offset(-1, -1)

Set DIC = CreateObject("Scripting.Dictionary")

For Each CellVal In aryTmp
DIC.Item(CellVal) = Empty
Next

aryTmp = DIC.Keys

For Each CellVal In aryTmp
For i = 0 To lstTasks.ListCount - 1
If CellVal < lstTasks.List(i) Then
bolAdded = True
lstTasks.AddItem CellVal, i
Exit For
End If
Next
If bolAdded Then
bolAdded = False
Else
lstTasks.AddItem CellVal
End If
Next

For i = 0 To lstIDs.ListCount - 1
lstIDs.Selected(i) = True
Next
End Sub

In a Standard Module named basMain

Option Explicit

Function RangeFound(SearchRange As Range, _
Optional FindWhat As String = "*", _
Optional StartingAfter As Range, _
Optional LookAtTextOrFormula As XlFindLookIn = xlValues, _
Optional LookAtWholeOrPart As XlLookAt = xlPart, _
Optional SearchRowCol As XlSearchOrder = xlByRows, _
Optional SearchUpDn As XlSearchDirection = xlPrevious, _
Optional bMatchCase As Boolean = False) As Range

If StartingAfter Is Nothing Then
Set StartingAfter = SearchRange(1)
End If

Set RangeFound = SearchRange.Find(What:=FindWhat, _
After:=StartingAfter, _
LookIn:=LookAtTextOrFormula, _
LookAt:=LookAtWholeOrPart, _
SearchOrder:=SearchRowCol, _
SearchDirection:=SearchUpDn, _
MatchCase:=bMatchCase)
End Function

Sub Start()
frmPicker.Show vbModal
End Sub
Hope that helps,

Mark

[Skopweb]

Hi GTO
This looks less Vb Scripting and more of a miracle to me :beerchug:
It works as i wanted it.
You are really great to help me out.
Just wanted to know, Incase if i need to have more column in Sheet1 and same to be reflected in the results sheet, wat modification would be required.


Regards
Skopweb

[GTO]

Okay, some fluke happened and it entered my post as blank. Here's the code commented, let's see if it 'sticks'.

basMain:

Option Explicit

'// By default, this simply finds the last row within the prescribed range that contains//
'// data. I find this an easy function to call, as we may simply use the optional //
'// parameters and include an argument or two, to quickly adjust usage to meet needs. //
Function RangeFound(SearchRange As Range, _
Optional FindWhat As String = "*", _
Optional StartingAfter As Range, _
Optional LookAtTextOrFormula As XlFindLookIn = xlValues, _
Optional LookAtWholeOrPart As XlLookAt = xlPart, _
Optional SearchRowCol As XlSearchOrder = xlByRows, _
Optional SearchUpDn As XlSearchDirection = xlPrevious, _
Optional bMatchCase As Boolean = False) As Range

If StartingAfter Is Nothing Then
Set StartingAfter = SearchRange(1)
End If

Set RangeFound = SearchRange.Find(What:=FindWhat, _
After:=StartingAfter, _
LookIn:=LookAtTextOrFormula, _
LookAt:=LookAtWholeOrPart, _
SearchOrder:=SearchRowCol, _
SearchDirection:=SearchUpDn, _
MatchCase:=bMatchCase)
End Function

Sub Start()
frmPicker.Show vbModal
End Sub

Userform:

Option Explicit

'// NOTE!: chnage DIC to As Object as shown below... so the code can run late-bound. //
'// Dimensioned at Module level in order to retain between procedures. I'm sure //
'// improvements could be made, I was writing on-the-fly (still slow, just 'speedy' for //
'// me. //
Dim DIC As Object
Dim rngTaskPage As Range
Dim aryPersonInfo As Variant

Private Sub cmdCancel_Click()
Unload Me
End Sub

Private Sub cmdExecute_Click()
Dim DIC2 As Object, _
i As Long, _
x As Long, _
y As Long, _
IndexRow As Long, _
lUBnd As Long, _
aryTmp As Variant, _
aryTransposed As Variant, _
aryOutput As Variant, _
rng As Range

'// Set a reference to Scripting's Dictionary. //
Set DIC2 = CreateObject("Scripting.Dictionary")

'// Get a collection of unique ID's, by using the Dictionary's Keys and ditching the//
'// items. //
For i = 0 To lstIDs.ListCount - 1
If lstIDs.Selected(i) Then
DIC2.Item(lstIDs.List(i)) = Empty
End If
Next

'// Note that this is the 'other' Dictionary. //
DIC.RemoveAll

'// Re-use the first Dictionary. //
For i = 0 To lstTasks.ListCount - 1
If lstTasks.Selected(i) Then
DIC.Item(lstTasks.List(i)) = Empty
End If
Next

'// Refer back to where we last Set rngTaskPage. For the example data, it now //
'// refers to A2:Q33 in 'Task Schedule'. We need the ID numbers and dates, but we //
'// will not loop thru them as you will see later. //
aryTmp = rngTaskPage.Value

'// We know we want 6 columns of data in our output, but we don't know how many //
'// rows of data that there will be to return. Since we can only PRESERVE values //
'// in the last dimensio of our array as we build it, we will flip what we want as //
'// output on it's side. This way, whilst we appear to be adding 'columns' to the //
'// arraya while looping, these will become 'rows' after transposing, so that the //
'// ending output array can be plunked into a sheet. //
ReDim aryTransposed(1 To 6, 0 To 0)

'// We skip looping thru the first column and row 2. //
For x = 2 To UBound(aryTmp, 1)
For y = 2 To UBound(aryTmp, 2)
'// See if the ID number in the column .Exists in the Dictionary we built //
'// using the vals selected in lstIDs. //
If DIC2.Exists(aryTmp(1, y)) Then
'// See if the Task in the row .Exists in the Dictionary that we built, //
'// using the vals selected in lstTasks. //
If DIC.Exists(aryTmp(x, y)) Then
'// If both the ID and Task are within our selections, then find //
'// out what which row we need to return info from, from the array //
'// we created from the 'Person Info' sheet. //
'// We do this, by first ripping the column from the array that //
'// contains the employee's ID, and then use Application.Match to //
'// return the row number. //
IndexRow = Application.Match(aryTmp(1, y), _
Application.Index(aryPersonInfo, 0, 1), _
0)

'// We now 'bump' the second dimension of our INITIAL (layed-out //
'// on it's side) array. Note that the Base of the 2nd dimension //
'// becomes 1, thus in our first pass thru the loop, the array is //
'// dimensioned 1 To 6, 1 to 1. //
ReDim Preserve aryTransposed(1 To 6, 1 To UBound(aryTransposed, 2) + 1)
'// Grab the current UBound of the 2nd dimension, so that we don't //
'// make Excel figure this out for the next several commands; //
lUBnd = UBound(aryTransposed, 2)
'// You'll want to step-thru this, to see that we are grabbing the //
'// date and task (string/name) from the array from 'Task Schedule,'//
'// and the employee's info from the array created from 'Person Info'//
aryTransposed(1, lUBnd) = aryTmp(x, 1)
aryTransposed(2, lUBnd) = aryPersonInfo(IndexRow, 1)
aryTransposed(3, lUBnd) = aryPersonInfo(IndexRow, 2)
aryTransposed(4, lUBnd) = aryPersonInfo(IndexRow, 3)
aryTransposed(5, lUBnd) = aryPersonInfo(IndexRow, 4)
aryTransposed(6, lUBnd) = aryTmp(x, y)
End If
End If
Next
Next

'// Size our final output array transposed to the built-up size of aryTransposed. //
ReDim aryOutput(1 To UBound(aryTransposed, 2), 1 To 6)

'// 'Manually' (thru code, rather than a supplied method/function) Transpose our //
'// 'layed-over' array, into an array we can plunk into a sheet. //
For x = 1 To UBound(aryOutput, 1)
For y = 1 To 6
aryOutput(x, y) = aryTransposed(y, x)
Next
Next

'// Plunk in our output and 'prettify' it. //
With ThisWorkbook
With .Worksheets.Add(After:=.Worksheets(.Worksheets.Count), Type:=xlWorksheet) _
.Range("A2").Resize(UBound(aryOutput, 1), UBound(aryOutput, 2))

Set rng = ThisWorkbook.Worksheets(.Parent.Name).Range(.Address)
Set rng = rng.Resize(1).Offset(-1)
.Value = aryOutput
.BorderAround , xlMedium, 0
With .Borders(xlInsideVertical)
.LineStyle = xlContinuous
.Weight = xlMedium
.ColorIndex = xlAutomatic
End With
With .Borders(xlInsideHorizontal)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
End With
End With

With rng
With .Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.Weight = xlMedium
.ColorIndex = 0
End With
With .Borders(xlEdgeTop)
.LineStyle = xlContinuous
.Weight = xlMedium
.ColorIndex = 0
End With
With .Borders(xlEdgeRight)
.LineStyle = xlContinuous
.Weight = xlMedium
.ColorIndex = 0
End With
With .Borders(xlInsideVertical)
.LineStyle = xlContinuous
.Weight = xlMedium
.ColorIndex = 0
End With
.Value = Array("Date", "ID", "Name", "Email Address", "Locarion", "Task Number")
.Font.Bold = True
.EntireColumn.AutoFit
End With

Unload Me
End Sub

Private Sub lstIDs_Change()
Call EnableExecute
End Sub

Private Sub lstTasks_Change()
Call EnableExecute
End Sub

Private Function EnableExecute()
Dim _
i As Long, _
x As Long, _
bolIDSelected As Boolean, _
bolTaskSelected As Boolean

'// Run thru both ListBox controls to see if at least one val is selected. //
For i = 0 To lstIDs.ListCount - 1
If lstIDs.Selected(i) Then
bolIDSelected = True
Exit For
End If
Next

For i = 0 To lstTasks.ListCount - 1
If lstTasks.Selected(i) Then
bolTaskSelected = True
Exit For
End If
Next

'// IF both lists have at least one val selected, then we can run, so enable our //
'// Execute button. //
If bolIDSelected And bolTaskSelected Then
cmdExecute.Enabled = True
Else
cmdExecute.Enabled = False
End If
End Function

Private Sub UserForm_Initialize()
Dim _
i As Long, _
lRow As Long, _
lCol As Long, _
aryTmp As Variant, _
CellVal As Variant, _
lstItem As Variant, _
bolAdded As Boolean, _
rngIDs As Range, _
rngPersonInfo As Range

With Me
.Caption = "Data Filter"
.cmdExecute.Enabled = False
End With

'// Find the last row with data in the ID column of 'Person Info.' //
Set rngIDs = RangeFound( _
SearchRange:=Range(shtPersonInfo.Range("B2"), _
shtPersonInfo.Cells(shtPersonInfo.Rows.Count, "B")) _
)
'// Something is junked, bail here... //
If rngIDs Is Nothing Then
Unload Me
MsgBox "No ID's were found...", vbInformation, vbNullString
End If

'// Reset the range to grab all ID numbers. //
Set rngIDs = Range(shtPersonInfo.Range("B2"), rngIDs)
'// Set another range (with all ea person's info) based on the rows that contain ID //
'// numbers... //
Set rngPersonInfo = rngIDs.Resize(, 4)
'// ...and plunk those values into an array. //
aryPersonInfo = rngPersonInfo.Value

'// Plunk the IDs into a ListBox. //
lstIDs.List = rngIDs.Value

'// In the Task Schedule sheet, find the last row with data. //
Set rngTaskPage = RangeFound( _
SearchRange:=Range( _
shtTaskSchedule.Range("B3"), _
shtTaskSchedule.Cells(shtTaskSchedule.Rows.Count, shtTaskSchedule.Columns.Count) _
) _
)
'// In case the Task Schedule sheet is empty, bailout, else... //
If rngTaskPage Is Nothing Then
Unload Me
MsgBox "No Tasks were listed on " & shtTaskSchedule.Name & "!", _
vbInformation, _
vbNullString
End If
'// ...record the last row, and... //
lRow = rngTaskPage.Row

'// (Setting to Nothing is normally a 'safety', but unnecessary in this case; I was //
'// writing too quickly.) //
Set rngTaskPage = Nothing
'// ...find the last column and record it. //
Set rngTaskPage = _
RangeFound( _
SearchRange:=Range(shtTaskSchedule.Range("B3"), _
shtTaskSchedule.Cells(shtTaskSchedule.Rows.Count, _
shtTaskSchedule.Columns.Count) _
), _
SearchRowCol:=xlByColumns _
)
lCol = rngTaskPage.Column

'// Now set a reference to the range we want to plunk into an array. With the sample//
'// data, this ends up being B3:Q33. //
Set rngTaskPage = Range(shtTaskSchedule.Range("B3"), shtTaskSchedule.Cells(lRow, lCol))

aryTmp = rngTaskPage.Value

'// Resize and reset the range to include the dates in Col A and IDs in Row 1. //
Set rngTaskPage = rngTaskPage _
.Resize(rngTaskPage.Rows.Count + 1, rngTaskPage.Columns.Count + 1) _
.Offset(-1, -1)

'// Create a Dictionary and loop unique tasks into the Keys. //
Set DIC = CreateObject("Scripting.Dictionary")

For Each CellVal In aryTmp
DIC.Item(CellVal) = Empty
Next

'// Then plunk the unique Tasks into an array. //
aryTmp = DIC.Keys

'// Maybe unnecessary, but I chose to alpha-sort the tasks on the way into the //
'// Listbox. //
For Each CellVal In aryTmp
For i = 0 To lstTasks.ListCount - 1
If CellVal < lstTasks.List(i) Then
bolAdded = True
lstTasks.AddItem CellVal, i
Exit For
End If
Next
If bolAdded Then
bolAdded = False
Else
lstTasks.AddItem CellVal
End If
Next

'// Then, since it appeared that you would normally want data returned on all //
'// IDs (employees) listed in the Person Info sheet, we simply pre-select all in the//
'// listbox. The user may of course deselect any not wanted. //
For i = 0 To lstIDs.ListCount - 1
lstIDs.Selected(i) = True
Next
End Sub

[GTO]

Hi GTO
This looks less Vb Scripting and more of a miracle to me :beerchug:
It works as i wanted it.
You are really great to help me out.
Just wanted to know, Incase if i need to have more column in Sheet1 and same to be reflected in the results sheet, wat modification would be required.


Regards
Skopweb

You are of course welcome. Reference your question, at quick glance, you would need to size aryTransposed and aryOutput differently, and of course, adjust the range referred to appropriately. With the commenting, I believe you could have a go at it.

Mark

[Skopweb]

Dear GTO
Thank-you for the code with the explaination. However, i tried to have 7 column instead of 6, it gave me a debug error. I had entered the values in column 7 of sheet 1
Please advise if the change made by me was correct or else.
Have highlighted them in RED

ReDim aryTransposed(1 To 7, 0 To 0)

'// We skip looping thru the first column and row 2. //
For x = 2 To UBound(aryTmp, 1)
For y = 2 To UBound(aryTmp, 2)
'// See if the ID number in the column .Exists in the Dictionary we built //
'// using the vals selected in lstIDs. //
If DIC2.Exists(aryTmp(1, y)) Then
'// See if the Task in the row .Exists in the Dictionary that we built, //
'// using the vals selected in lstTasks. //
If DIC.Exists(aryTmp(x, y)) Then
'// If both the ID and Task are within our selections, then find //
'// out what which row we need to return info from, from the array //
'// we created from the 'Person Info' sheet. //
'// We do this, by first ripping the column from the array that //
'// contains the employee's ID, and then use Application.Match to //
'// return the row number. //
IndexRow = Application.Match(aryTmp(1, y), _
Application.Index(aryPersonInfo, 0, 1), _
0)

'// We now 'bump' the second dimension of our INITIAL (layed-out //
'// on it's side) array. Note that the Base of the 2nd dimension //
'// becomes 1, thus in our first pass thru the loop, the array is //
'// dimensioned 1 To 6, 1 to 1. //
ReDim Preserve aryTransposed(1 To 7, 1 To UBound(aryTransposed, 2) + 1)
'// Grab the current UBound of the 2nd dimension, so that we don't //
'// make Excel figure this out for the next several commands; //
lUBnd = UBound(aryTransposed, 2)
'// You'll want to step-thru this, to see that we are grabbing the //
'// date and task (string/name) from the array from 'Task Schedule,'//
'// and the employee's info from the array created from 'Person Info'//
aryTransposed(1, lUBnd) = aryTmp(x, 1)
aryTransposed(2, lUBnd) = aryPersonInfo(IndexRow, 1)
aryTransposed(3, lUBnd) = aryPersonInfo(IndexRow, 2)
aryTransposed(4, lUBnd) = aryPersonInfo(IndexRow, 3)
aryTransposed(5, lUBnd) = aryPersonInfo(IndexRow, 4)
aryTransposed(6, lUBnd) = aryPersonInfo(IndexRow, 5)
aryTransposed(7, lUBnd) = aryTmp(x, y)
End If
End If
Next
Next

'// Size our final output array transposed to the built-up size of aryTransposed. //
ReDim aryOutput(1 To UBound(aryTransposed, 2), 1 To 7)

'// 'Manually' (thru code, rather than a supplied method/function) Transpose our //
'// 'layed-over' array, into an array we can plunk into a sheet. //
For x = 1 To UBound(aryOutput, 1)
For y = 1 To 7
aryOutput(x, y) = aryTransposed(y, x)
Next
Next

[Skopweb]

Hello GTO
Finally i was able to get this working. Thanks once again for all your help.
:beerchug:
Regards
Skopweb

[GTO]

Hello GTO
Finally i was able to get this working. Thanks once again for all your help.
:beerchug:
Regards
Skopweb

Hi Scopweb,

Sorry I didn't get back sooner. I was having a dickens of a time with the code for some reason. I see that you succeeded in modifying it, that's nice :-)

Here's the rather hodge-podge fixes I came up with. No doubt could be improved upon, but in gist, it should 'auto-adjust' for additional columns of info in the Person Info sheet.

This is just the Userform code, the standard module stays the same.


Option Explicit

Dim DIC As Object
Dim rngTaskPage As Range
Dim aryHeader As Variant
Dim aryPersonInfo As Variant

Private Sub cmdCancel_Click()
Unload Me
End Sub

Private Sub cmdExecute_Click()
Dim DIC2 As Object, _
i As Long, _
x As Long, _
y As Long, _
IndexRow As Long, _
lUBnd As Long, _
lEmpCols As Long, _
aryTmp As Variant, _
aryTransposed As Variant, _
aryOutput As Variant, _
rng As Range

Set DIC2 = CreateObject("Scripting.Dictionary")

For i = 0 To lstIDs.ListCount - 1
If lstIDs.Selected(i) Then
DIC2.Item(lstIDs.List(i)) = Empty
End If
Next

DIC.RemoveAll

For i = 0 To lstTasks.ListCount - 1
If lstTasks.Selected(i) Then
DIC.Item(lstTasks.List(i)) = Empty
End If
Next

aryTmp = rngTaskPage.Value

lEmpCols = UBound(aryPersonInfo, 2)
ReDim aryTransposed(1 To lEmpCols + 2, 0 To 0)

For x = 2 To UBound(aryTmp, 1)
For y = 2 To UBound(aryTmp, 2)

If DIC2.Exists(aryTmp(1, y)) Then
If DIC.Exists(aryTmp(x, y)) Then

IndexRow = Application.Match(aryTmp(1, y), _
Application.Index(aryPersonInfo, 0, 1), _
0)

ReDim Preserve aryTransposed(1 To lEmpCols + 2, 1 To UBound(aryTransposed, 2) + 1)

lUBnd = UBound(aryTransposed, 2)

aryTransposed(1, lUBnd) = aryTmp(x, 1)

Dim a
a = aryPersonInfo

For i = 2 To lEmpCols + 2 - 1
aryTransposed(i, lUBnd) = aryPersonInfo(IndexRow, i - 1)
Next
aryTransposed(lEmpCols + 2, lUBnd) = aryTmp(x, y)
End If
End If
Next
Next

ReDim aryOutput(1 To UBound(aryTransposed, 2), 1 To lEmpCols + 2)

For x = 1 To UBound(aryOutput, 1)
For y = 1 To lEmpCols + 2
aryOutput(x, y) = aryTransposed(y, x)
Next
Next

With ThisWorkbook
With .Worksheets.Add(After:=.Worksheets(.Worksheets.Count), Type:=xlWorksheet) _
.Range("A2").Resize(UBound(aryOutput, 1), UBound(aryOutput, 2))

Set rng = ThisWorkbook.Worksheets(.Parent.Name).Range(.Address)
Set rng = rng.Resize(1).Offset(-1)
.Value = aryOutput
.BorderAround , xlMedium, 0
With .Borders(xlInsideVertical)
.LineStyle = xlContinuous
.Weight = xlMedium
.ColorIndex = xlAutomatic
End With
With .Borders(xlInsideHorizontal)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
End With
End With

With rng
With .Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.Weight = xlMedium
.ColorIndex = 0
End With
With .Borders(xlEdgeTop)
.LineStyle = xlContinuous
.Weight = xlMedium
.ColorIndex = 0
End With
With .Borders(xlEdgeRight)
.LineStyle = xlContinuous
.Weight = xlMedium
.ColorIndex = 0
End With
With .Borders(xlInsideVertical)
.LineStyle = xlContinuous
.Weight = xlMedium
.ColorIndex = 0
End With

.Cells(1).Value = "Date"
For i = 2 To .Columns.Count - 1
.Cells(i).Value = aryHeader(i - 1)
Next
.Cells(.Columns.Count).Value = "Task Number"

.Font.Bold = True
.EntireColumn.AutoFit
End With

Unload Me
End Sub

Private Sub lstIDs_Change()
Call EnableExecute
End Sub

Private Sub lstTasks_Change()
Call EnableExecute
End Sub

Private Function EnableExecute()
Dim _
i As Long, _
x As Long, _
bolIDSelected As Boolean, _
bolTaskSelected As Boolean

For i = 0 To lstIDs.ListCount - 1
If lstIDs.Selected(i) Then
bolIDSelected = True
Exit For
End If
Next

For i = 0 To lstTasks.ListCount - 1
If lstTasks.Selected(i) Then
bolTaskSelected = True
Exit For
End If
Next

If bolIDSelected And bolTaskSelected Then
cmdExecute.Enabled = True
Else
cmdExecute.Enabled = False
End If
End Function

Private Sub UserForm_Initialize()
Dim _
i As Long, _
lRow As Long, _
lCol As Long, _
aryTmp As Variant, _
CellVal As Variant, _
lstItem As Variant, _
bolAdded As Boolean, _
rngIDs As Range, _
rngPersonInfo As Range, _
rngHeader As Range

With Me
.Caption = "Data Filter"
.cmdExecute.Enabled = False
End With

Set rngIDs = RangeFound( _
SearchRange:=Range(shtPersonInfo.Range("B2"), _
shtPersonInfo.Cells(shtPersonInfo.Rows.Count, "B")) _
)
If rngIDs Is Nothing Then
Unload Me
MsgBox "No ID's were found...", vbInformation, vbNullString
End If

'''''''''''''
' Set rngPersonInfo = rngIDs.Resize(, 4)

With shtPersonInfo
Set rngPersonInfo = _
Range(.Range("B2"), _
.Cells(rngIDs.Row, _
RangeFound(SearchRange:=Range(.Range("B2"), _
.Cells(.Rows.Count, .Columns.Count)), _
SearchRowCol:=xlByColumns) _
.Column) _
)
Set rngIDs = Range(shtPersonInfo.Range("B2"), rngIDs)
End With

Set rngHeader = rngPersonInfo.Rows(1).Offset(-1)
ReDim aryHeader(1 To rngHeader.Columns.Count)
For i = 1 To rngHeader.Columns.Count
aryHeader(i) = rngHeader.Cells(i).Value
Next

aryPersonInfo = rngPersonInfo.Value

Dim a: a = aryPersonInfo

lstIDs.List = rngIDs.Value

Set rngTaskPage = RangeFound( _
SearchRange:=Range( _
shtTaskSchedule.Range("B3"), _
shtTaskSchedule.Cells(shtTaskSchedule.Rows.Count, shtTaskSchedule.Columns.Count) _
) _
)

If rngTaskPage Is Nothing Then
Unload Me
MsgBox "No Tasks were listed on " & shtTaskSchedule.Name & "!", _
vbInformation, _
vbNullString
End If

lRow = rngTaskPage.Row

Set rngTaskPage = Nothing

Set rngTaskPage = _
RangeFound( _
SearchRange:=Range(shtTaskSchedule.Range("B3"), _
shtTaskSchedule.Cells(shtTaskSchedule.Rows.Count, _
shtTaskSchedule.Columns.Count) _
), _
SearchRowCol:=xlByColumns _
)
lCol = rngTaskPage.Column

Set rngTaskPage = Range(shtTaskSchedule.Range("B3"), shtTaskSchedule.Cells(lRow, lCol))

aryTmp = rngTaskPage.Value

Set rngTaskPage = rngTaskPage _
.Resize(rngTaskPage.Rows.Count + 1, rngTaskPage.Columns.Count + 1) _
.Offset(-1, -1)

Set DIC = CreateObject("Scripting.Dictionary")

For Each CellVal In aryTmp
DIC.Item(CellVal) = Empty
Next

aryTmp = DIC.Keys

For Each CellVal In aryTmp
For i = 0 To lstTasks.ListCount - 1
If CellVal < lstTasks.List(i) Then
bolAdded = True
lstTasks.AddItem CellVal, i
Exit For
End If
Next
If bolAdded Then
bolAdded = False
Else
lstTasks.AddItem CellVal
End If
Next

For i = 0 To lstIDs.ListCount - 1
lstIDs.Selected(i) = True
Next
End Sub

Mark

[Skopweb]

Hey Mark
This works fine too. However, dont bother on this but it gives an runtime error if the task selected to filter is not the task assigned to the individual listed in Sheet 1. Hope you have got it

Regards
Skopweb