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