Excel vba过滤数据并将过滤列表中的值设置为变量

Question

我的代码有点麻烦。我试图过滤M列中的值，然后将M中的一个值设置为变量deptName。这适用于除一个之外的每个迭代，而不是将deptName设置为M中的值，而是将其设置为等于A1中的值。它只是为迭代中的一个做到这一点，我不知道为什么。

For criteria = 1 To UBound(degreeArray) 
    degreeWS.range(fields).AutoFilter Field:=degreeColumn, Criteria1:=degreeArray(criteria) 
    degreeWS.range("A2:A" & lrd).EntireRow.Copy 

    Dim deptName As Variant 
    range("M2", Cells(Rows.count, "M").End(xlUp)).SpecialCells(xlCellTypeVisible).Cells(1, 1).Select 
    deptName = Selection 

下面是数据的一个例子

A  B  C  D  E  F  G H  I   J  K L  M 
ID  FName LName   Degree Major Col Dept1 Dept1Name Major2 Col Dept2 Dept2Name 
100 Jack Smith   MBA MAJOR1 UK BIO BIOLOGY  MAJOR2 UK CHEM CHEMISTRY 
101 Sally Johnson   BS  MAJOR1 UK EDU EDUCATION MAJOR2 UK BIO BIOLOGY 
102 Bryan Carter   BSB MAJOR1 UK CHEM CHEMISTRY MAJOR2 UK EDU EDUCATION 
104 Mason Harper   BS  MAJOR1 UK BIO BIOLOGY  MAJOR2 UK EDU EDUCATION 
104 Harry Potter   MBA MAJOR1 UK CHEM CHEMISTRY MAJOR2 UK BIO BIOLOGY 

Answer 1

我发现问题出在deptName范围之内。我在.value之前添加了End(xlDown)，现在代码完美无缺。

Dim deptName As Variant 
     deptName = range("M1:M" & Cells(Rows.count, "M").End(xlUp).Row).SpecialCells(xlCellTypeVisible).End(xlDown).Value 

Answer 2

@Lowpar这就是我的全部代码洛斯像现在。发生错误的部分最后是

Sub Department2_Filter() 

'============================== 
         'Degree Workbook Variables 

Dim lrd As Long      'The last row of data in the degree workbook worksheet 
Dim criteria As Long    'What is being searched for/filtered by 
Dim count As Long     'Counter for the number of rows to be copied 
Dim degreeColumn As Long   'The column that contains the data you want to sort by 

Dim degreeWS As Worksheet   'The worksheet with the original unsorted data 
Dim degreeArray As Variant   'The array of data to be looped through 
Dim fields As String    'The column headers in the original degree sheet 
Dim fileLocation As String   'The file path where the new workbooks will be stored 



'=========================================== 

      'How to set up the macro and workbook so the data can then be sorted 

'Sets the active worksheet as the worksheet with the data to be parsed. 
Sheet with all rows of degree data 
Set degreeWS = ActiveSheet 

'\\\\CHANGE FILE PATH HERE\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ 

'The new workbooks are currently set to save on drive E in the Courses folder. To change this location: 
' 1. open the file explorer 
' 2. Find the folder where you would like them to be saved 
' 3. Right click the address bar at the top and select copy address 
' 4. Delete the current path address and paste the new one. 
' 5. add a \ at the end of the address inside the ending " 

fileLocation = "H:\Degrees List\Sorted_Workbooks\" 



'\\\\CHANGE FILE PATH HERE\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ 



'A1:N1 is the row of cells that contain the column headers for the degree workbook. If a new column 
'is ever added or one is deleted simply change the AQ to the new column letter to add or remove headers. 
fields = "A1:AQ1" 


'============================================ 
         'Determining what data to parse 


'This section displays a dialogue box so that the user can select to sort the data by the major 1 department information column 

degreeColumn = Application.InputBox("Enter the column number for Major2Dept 
(ACC, BIO, MMB...)" & vbLf _ 
    & vbLf & "Example: For column A type 1; Column K Type 2...." _ 
    & vbLf & "Press OK", Type:=1) 
If degreeColumn = 0 Then Exit Sub 



'Finds the last row in the work sheet containing data and the finds the unique values in the column being 
'searched; therefor each major will be a unique value and rows will not be copied more than once. 

lrd = degreeWS.Cells(degreeWS.Rows.count, degreeColumn).End(xlUp).Row 
Application.ScreenUpdating = False 
degreeWS.Columns(degreeColumn).AdvancedFilter Action:=xlFilterCopy, 
CopyToRange:=degreeWS.range("ZZ1"), Unique:=True 
degreeWS.Columns("ZZ:ZZ").Sort Key1:=degreeWS.range("ZZ2"), 
Order1:=xlAscending, Header:=xlYes, _ 
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, 
DataOption1:=xlSortNormal 

'The now sorted data is put into a list which will be looped through by the major 1 department's abbreviation 
'The list is then cleared because it is no longer needed 
degreeArray = Application.WorksheetFunction.Transpose(degreeWS.range("ZZ2:ZZ" & Rows.count).SpecialCells(xlCellTypeConstants)) 
degreeWS.range("ZZ:ZZ").Clear 
degreeWS.range(fields).AutoFilter 

'==================================== 
       'Now that we have a filtered list of uniqe values we can 
     'loop through each row and match it with one of the unique values in the degreeArray 


'For every unique major 1 department, all rows related to that department will be copied 
'and placed into a new workbook named after that criteria and the current month and year. 
For criteria = 1 To UBound(degreeArray) 
    degreeWS.range(fields).AutoFilter Field:=degreeColumn, Criteria1:=degreeArray(criteria) 
    degreeWS.range("A2:A" & lrd).EntireRow.Copy 

    Dim deptName As Variant 
    ' deptName = range("M2", Cells(Rows.count, "M").End(xlUp)).SpecialCells(xlCellTypeVisible).Cells(1, 1).Value    '<--------FIX 
    ' deptName = range("M2", Cells(Rows.count, "M").End(xlUp)).SpecialCells(xlCellTypeVisible).Cells(1).Value 


    Dim LR As Long 
    LR = range("M" & Rows.count).End(xlUp).Row 
    deptName = range("M2:M" & LR).SpecialCells(xlCellTypeVisible).Value 





    Workbooks.Open Filename:=fileLocation & deptName & "- " & degreeArray(criteria) & " " & Format(Date, "MMM-YY") & ".xlsx", Password:="sp17" 
    range("A1").End(xlDown).Offset(1, 0).PasteSpecial xlPasteAll 
    Cells.Columns.AUTOFIT 

'Removing any duplicate values 
    Cells.RemoveDuplicates Columns:=Array(1) 


'**====================================== 

'============================================= 
        'Saves the file by the criteria and adds todays month and year to it as well as the password sp17 

    ActiveWorkbook.Save 
    ActiveWorkbook.Close False 
'**========================================= 
       'Returns back to degree workbook 
    degreeWS.range(fields).AutoFilter Field:=degreeColumn 
Next criteria 

'Message box to indicate how many total rows of the original worksheet had data and how many were succesfully transferred to new workbooks. 

degreeWS.AutoFilterMode = False 
MsgBox "Rows succesfilly copied" 
Application.ScreenUpdating = True 


End Sub