我的代码有点麻烦。我试图过滤M列中的值，然后将M中的一个值设置为变量deptName。这适用于除1之外的每次迭代，而不是将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
答案 0 :(得分：0)
@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
答案 1 :(得分：0)
我发现问题出在deptName范围内。我在.value之前将End(xlDown)添加到它的末尾，现在代码完美无缺。
Dim deptName As Variant
deptName = range("M1:M" & Cells(Rows.count, "M").End(xlUp).Row).SpecialCells(xlCellTypeVisible).End(xlDown).Value