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

我的代码有点麻烦。 我试图过滤M列中的值，然后将M中的一个值设置为variablesdeptName。 这适用于除一个之外的每个迭代，而不是将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 

这是一个数据的例子

  ABCDEFGHIJKLM 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

@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 

Answer 2

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

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