VBA to Copy Rows to Another Worksheet Based on Criteria

[MrsTeach]

I'd really appreciate help with the following please?

I have a list where the user selects a Local Authority which then triggers a macro. I need the macro to copy all matching rows on another worksheet to a new worksheet so that the worksheet only contains data for the Local Authority.

I have the drop-down list and a macro button and can create the new worksheet but I'd like an optimal solution for matching against the other worksheet as it has approx 10k rows.

The user selects a Local Authority (from a drop-down box on the first sheet), which then needs to be matched to a LA code (on another sheet) then copy all matching entries to a new worksheet.

Book1.xlsx
	A	B	C	D	E	F
1	LA Code	LA NAME
2	1	Norfolk, Suffolk and Cambridgeshire
3	2	Bedforshire & Hertfordshire
4	3	Essex
5	4	North West London
6	5	North Central London
7	6	North East London
8	7	South East London
9	8	South West London
10	9	Northumberland, Tyne & Wear
11	10	County Durham and Tees Valley
12	11	North and East Yorkshire and Northern Lincolnshire
13	12	West Yorkshire
14	13	Cumbria and Lancashire
15	14	Greater Manchester
16	15	Cheshire and Merseyside
17	16	Thames Valley
18	17	Hampshire and Isle of Wight
19	18	Kent and Medway
20	19	Surrey and Sussex
21	20	Avon, Gloucestershire and Wiltshire
22	21	South West Peninsula
23	22	Dorset and Somerset
24	23	South Yorkshire
25	24	Trent
26	25	Leicestershire, Northamptonshire and Rutland
27	26	Shropshire and Staffordshire
28	27	Birmingham and the Black Country
29	28	Coventry, Warwickshire, Herefordshire and Worcestershire
30
Index

For example. If the user selected "Norfolk, Suffolk and Cambridgeshire" on Sheet 1, I need to find the matching LA code on the 'Index' worksheet and copy all rows for that Authority on the 'Data' worksheet to a new Sheet 3 (which needs to be given the name of the selected Local Authority: e.g.Norfolk, Suffolk and Cambridgeshire)

Book1.xlsx
	A	B	C	D	E	F	G
1	school	nr	class	Health Auth	sex	age
2	101051	1	1	20	1	7
3	101151	1	1	20	1	8
4	101201	1	1	20	2	3
5	101271	1	2	20	1	9
6	101271	2	2	20	2	4
7	101351	1	3	20	2	5
8	101351	2	3	20	2	5
9	101351	3	3	20	2	6
10	101371	1	2	20	1	7
11	101371	2	2	20	2	8
12	102051	1	2	11	1	5
13	102051	2	2	11	2	4
14	102201	1	2	11	2	6
15	102201	2	2	11	1	7
16	102251	1	4	11	2	5
17	102251	2	4	11	1	8
18	102251	3	4	11	2	9
19	102251	4	4	11	1	6
20	102271	1	3	11	2	6
21	102271	2	3	11	1	8
22	102271	3	3	11	2	7
23	102341	1	1	11	2	9
24	102351	1	1	11	2	4
25	103051	1	1	26	2	5
26	103181	1	2	26	1	5
27	103181	2	2	26	2	4
28	103201	1	1	26	2	6
29	103371	1	1	26	2	10
30
Data

Hope that makes sense and anyone can help! Thanks in advance.

 

[DanteAmor]

Hi @MrsTeach , happy new year!

You didn't mention a few things:
- The name of the first sheet.
- In which cell of the first sheet do you have the drop-down list
- The name of the destination sheet.
- In which column of the Data sheet should the LA Code be searched?

But don't worry, you can adjust that data in the macro.
I added some comments in the macro for you to make those adjustments. They are marked in blue in the code.

Try this:

Sub CopyRows()
  Dim sh1 As Worksheet, sh3 As Worksheet, shI As Worksheet, shD As Worksheet
  Dim f As Range, cellName As Range
  Dim LaCode As Variant
  Dim a As Variant, b As Variant
  Dim i As Long, j As Long, k As Long
 
  'Fit to the name of your sheets
  Set sh1 = Sheets("Sheet1")  'first sheet
  Set sh3 = Sheets("Sheet3")  'New sheet
  Set shI = Sheets("Index")   'Index sheet
  Set shD = Sheets("Data")    'Data sheet
 
  Set cellName = sh1.Range("B2")  'Fit to the cell with drop-down box on the first sheet
 
  If cellName.Value = "" Then
    MsgBox "Select name"
    Exit Sub
  End If
 
  'Look up the name in the Index sheet and get the LA code
  Set f = shI.Range("B:B").Find(cellName.Value, , xlValues, xlWhole, , , False)
  If f Is Nothing Then
    MsgBox "That name does not exist"
    Exit Sub
  Else
    LaCode = shI.Range("A" & f.Row).Value
  End If
 
  a = shD.Range("A2:F" & shD.Range("A" & Rows.Count).End(3).Row).Value
  ReDim b(1 To UBound(a, 1), 1 To UBound(a, 2))
 
  For i = 1 To UBound(a, 1)
    'fit the column number to search for the LaCode, 1 for "A", 2 for "B", 3 for "C", etc.
    If a(i, 2) = LaCode Then
      k = k + 1
      For j = 1 To UBound(a, 2)
        b(k, j) = a(i, j)
      Next
    End If
  Next
 
  sh3.Cells.ClearContents
  shD.Rows(1).Copy sh3.Range("A1")
  If k = 0 Then
    MsgBox "No records"
  Else
    sh3.Range("A2").Resize(k, UBound(b, 2)).Value = b
  End If
End Sub

 

[HaHoBe]

Hi,

using Advanced Filter setting sheets up like

MrE_1226120_170051C_vba to copy rows to_230105.xlsm
	A	B	C	D	E	F	G
1	LA Code	LA NAME		ChooseLocal Authority	North and East Yorkshire and Northern Lincolnshire		Health Auth
2	1	Norfolk, Suffolk and Cambridgeshire					11
3	2	Bedforshire & Hertfordshire
4	3	Essex
5	4	North West London
6	5	North Central London
7	6	North East London
8	7	South East London
9	8	South West London
10	9	Northumberland, Tyne & Wear
11	10	County Durham and Tees Valley
12	11	North and East Yorkshire and Northern Lincolnshire
13	12	West Yorkshire
14	13	Cumbria and Lancashire
15	14	Greater Manchester
16	15	Cheshire and Merseyside
17	16	Thames Valley
18	17	Hampshire and Isle of Wight
19	18	Kent and Medway
20	19	Surrey and Sussex
21	20	Avon, Gloucestershire and Wiltshire
22	21	South West Peninsula
23	22	Dorset and Somerset
24	23	South Yorkshire
25	24	Trent
26	25	Leicestershire, Northamptonshire and Rutland
27	26	Shropshire and Staffordshire
28	27	Birmingham and the Black Country
29	28	Coventry, Warwickshire, Herefordshire and Worcestershire
Index

Cell Formulas
Range	Formula
G2	G2	=IFERROR(INDEX(A:A,MATCH(E1,B:B,0)),"")

Named Ranges
Name	Refers To	Cells
_FilterDatabase	=Index!$A$1:$F$29	G2
PickList	=Index!$B$2:$B$29	G2

Cells with Data Validation
Cell	Allow	Criteria
E1	List	=PickList

MrE_1226120_170051C_vba to copy rows to_230105.xlsm
	A	B	C	D	E	F
1	school	nr	class	Health Auth	sex	age
2	101051	1	1	20	1	7
3	101151	1	1	20	1	8
4	101201	1	1	20	2	3
5	101271	1	2	20	1	9
6	101271	2	2	20	2	4
7	101351	1	3	20	2	5
8	101351	2	3	20	2	5
9	101351	3	3	20	2	6
10	101371	1	2	20	1	7
11	101371	2	2	20	2	8
12	102051	1	2	11	1	5
13	102051	2	2	11	2	4
14	102201	1	2	11	2	6
15	102201	2	2	11	1	7
16	102251	1	4	11	2	5
17	102251	2	4	11	1	8
18	102251	3	4	11	2	9
19	102251	4	4	11	1	6
20	102271	1	3	11	2	6
21	102271	2	3	11	1	8
22	102271	3	3	11	2	7
23	102341	1	1	11	2	9
24	102351	1	1	11	2	4
25	103051	1	1	26	2	5
26	103181	1	2	26	1	5
27	103181	2	2	26	2	4
28	103201	1	1	26	2	6
29	103371	1	1	26	2	10
Data

Code goes behind sheet Index and will be triggered each time a value is chosen in E1:

Private Sub Worksheet_Change(ByVal Target As Range)
Dim wsNew As Worksheet
If Target.Count > 1 Then Exit Sub
If Not Intersect(Target, Range("E1")) Is Nothing Then
  If WorksheetFunction.CountIf(Sheets("Data").Columns(4), Worksheets("Index").Range("G2").Value) > 0 Then
    If Not Evaluate("ISREF('" & Left(Range("E1").Value, 31) & "'!A1)") Then
      Set wsNew = Worksheets.Add(After:=Worksheets(ThisWorkbook.Worksheets.Count))
      wsNew.Name = Left(Sheets("Index").Range("E1").Value, 31)
    Else
      Set wsNew = Worksheets(Left(Sheets("Index").Range("E1").Value, 31))
      wsNew.Cells.ClearContents
    End If
    Sheets("Data").Range("A1:F" & Sheets("data").Cells(Rows.Count, "A").End(xlUp).Row).AdvancedFilter Action:=xlFilterCopy, _
        CriteriaRange:=Sheets("Index").Range("G1:G2"), _
        CopyToRange:=wsNew.Range("A5:F5"), _
        Unique:=False
  End If
End If
Set wsNew = Nothing
End Sub

Ciao,
Holger