vba to select entries from a table and copy into a new table

[cjcass]

Hi,
I'm looking for some code that will select entries in a table based on the criteria in two cells and then copy the selected entries into another table. The two tables are on different sheets. Hopefully the pic below is fairly self-explanatory. So, in the example, the yellow cells in the 'Results' wksht are the criteria (which will vary) and when a different question is selected from a dropdown list in cell C20 (Criteria 2) I would like the vba to execute - it will take the two criteria, go and find the relevant information in the table in the 'Comments' wksheet and then paste them into cells C25 down. The table columns will vary in their number of entries/rows populated. The questions will be fixed in position from B4:Z4.
Hope you can help?

 

[wideboydixon]

Do you definitely want VBA? With the data as presented, it's possible to do this using (a little complex) formulas like this:

Book1
	B	C	D	E	F	G
2	Which fruit do you like best?		Which cars do you like best?		Which ### do you like?
3	Department 1	I like apples and pears	Department 7	Bentley	Department 4	###1
4	Department 2	Pears	Department 10	Ford and Renault	Department 1	###2
5	Department 3	I like oranges	Department 3	Jaguar	Department 2	###3
6	Department 4	I don't like anything	Department 4	Peugeot	Department 3	###4
7	Department 1	Date and plums	Department 1	Fiats and Rollers	Department 4	###5
8	Department 2	Apples	Department 2	Vans	Department 1	###6
9	Department 3	Bananas and mango			Department 3	###7
10	Department 4	Pears
11	Department 4	Oranges and Lemons
Comments

Book1
	B	C
2	Criteria 1:	Department 4
3	Criteria 2:	Which fruit do you like best?
4
5	Result:	I don't like anything
6		Pears
7		Oranges and Lemons
Results

Cell Formulas
Range	Formula
C5	{=IFERROR(INDEX(INDEX(Comments!$B$2:$G$11,,MATCH($C$3,Comments!$B$2:$F$2,0)+1),SMALL(IF(INDEX(Comments!$B$2:$G$11,,MATCH($C$3,Comments!$B$2:$F$2,0))=$C$2,ROW(INDEX(Comments!$B$2:$G$11,,MATCH($C$3,Comments!$B$2:$F$2,0)))-ROW(Comments!$B$2)+1),ROWS($C$5:$C5))),"")}
Press CTRL+SHIFT+ENTER to enter array formulas.

WBD

 

[cjcass]

Hi WBD, thanks for the initial solution but I'm really looking for VBA as the tables could ultimately be very big (up to 50,000 rows) so I really don't want to use large array formulas, thanks.

 

[wideboydixon]

Hey,

OK. You'll need to change the values at the top of the code to match the cells/rows where the data resides but give this a shot:

' Change these constants as appropriate
Private Const DepartmentCriteriaCell = "C2"
Private Const QuestionCriteriaCell = "C3"
Private Const ResultsCell = "C5"
Private Const QuestionRow = "2:2"
Public Sub GetCriteriaResults()

Dim commentsSheet As Worksheet
Dim resultsSheet As Worksheet
Dim lastRow As Long
Dim thisRow As Long
Dim qColumn As Variant
Dim criteriaDepartment As String
Dim criteriaQuestion As String
Dim resultCount As Long

' Turn off screen updating
Application.ScreenUpdating = False

' Set up the sheets
Set commentsSheet = Sheets("Comments")
Set resultsSheet = Sheets("Results")

' Clear out the results
lastRow = resultsSheet.Cells(resultsSheet.Rows.Count, resultsSheet.Range(ResultsCell).Column).End(xlUp).Row
If lastRow > resultsSheet.Range(ResultsCell).Row Then
    resultsSheet.Range(resultsSheet.Range(ResultsCell), resultsSheet.Cells(lastRow, resultsSheet.Range(ResultsCell).Column)).ClearContents
End If

' Get the criteria
criteriaDepartment = resultsSheet.Range(DepartmentCriteriaCell).Value
criteriaQuestion = resultsSheet.Range(QuestionCriteriaCell).Value

' Find the question column
qColumn = Application.Match(criteriaQuestion, commentsSheet.Range(QuestionRow), 0) ' Specify the row with the questions on it

' Quit out if we didn't find it
If IsError(qColumn) Then
    MsgBox "Unable to find the question in the Comments sheet", vbExclamation
    Application.ScreenUpdating = True
    Exit Sub
End If

' Find the last row in this column
lastRow = commentsSheet.Cells(commentsSheet.Rows.Count, qColumn).End(xlUp).Row

' Now look for the appropriate answers
resultCount = 0
For thisRow = commentsSheet.Range(QuestionRow).Row + 1 To lastRow
    If commentsSheet.Cells(thisRow, qColumn).Value = criteriaDepartment Then
        resultsSheet.Range(ResultsCell).Offset(resultCount, 0).Value = commentsSheet.Cells(thisRow, qColumn + 1).Value
        resultCount = resultCount + 1
    End If
Next thisRow

' Turn on screen updating again
Application.ScreenUpdating = True

End Sub

WBD

 

[cjcass]

Works brilliantly!!
Thanks again WBD - a great help

 

[cjcass]

Hi WBD (if you're around),
I messed up yesterday when I came back and said it worked brilliantly, stupidly I still had your array formulas in the Results column so the results were displaying anyway!!
When I removed the array formulas it stopped working, so as it stands at the moment the code doesn't appear to be working - no results are coming through when cell C3 is changed from the dropdown list in the Results tab.
The values at the top of the code match the cells/rows where the data resides, so that's not the issue.
Any thoughts?
Rgds,