Excel创build基于其他单元格的分类列表
我想要做的是拿我的预算表，并按特定的顺序sorting。 这正是我所拥有的：
列A =预算项目的名称（账单和支付）
B栏=该项目到期的月份。
列C =项目的用途。
我想创build一些VBA代码，当一个button被按下时，它将从这些列中获取这些信息，并在列B中sorting，如下所示：
1 - PayDay - 1000 4 - Cell Phone - 75 5 - Mortgage - 1350
编辑：
我一直在做这个VBA。 只需要弄清楚如何放入sortingfunction，以便按日栏sorting我的结果。
Sub CreateList() ' Clear the current records currentRow = 2 While currentRow < 200 If IsEmpty(Worksheets("Jan").Cells(currentRow, 9)) Then GoTo Generate End If Worksheets("Jan").Cells(currentRow, 9).Value = "" Worksheets("Jan").Cells(currentRow, 10).Value = "" Worksheets("Jan").Cells(currentRow, 11).Value = "" Worksheets("Jan").Cells(currentRow, 12).Value = "" currentRow = currentRow + 1 Wend Generate: ' Generate new list titleCol = 1 dayCol = 2 amountCol = 3 currentListRow = 2 currentSheet = 1 While currentSheet < 2 currentRow = 7 cellVal = "" While currentRow < 800 cellVal = Worksheets("Jan").Cells(currentRow, dayCol).Text If Not IsEmpty(cellVal) Then If Not cellVal = "0" Then If Not cellVal = "" Then If Not cellVal = "Due Date" Then ' Set vals in list cells Worksheets("Jan").Cells(currentListRow, 10).Value = Worksheets("Jan").Cells(currentRow, dayCol).Text Worksheets("Jan").Cells(currentListRow, 9).Value = Worksheets("Jan").Cells(currentRow, titleCol).Text Worksheets("Jan").Cells(currentListRow, 11).Value = Worksheets("Jan").Cells(currentRow, amountCol).Text currentListRow = currentListRow + 1 End If End If End If End If currentRow = currentRow + 1 Wend currentSheet = currentSheet + 1 Wend End Sub
在whytheq的帮助下，我想出了这个解决scheme。 第一个Sub将字段复制到一个新的区域。 第二个子对新创build的列表按日列进行sorting。 第三个小组更改任何新创build的列表项不标记为我的或我的妻子的名字，使他们消极。 我这样做，所以我可以添加一个字段在新列表右侧的数字相关的每个列表项目调整我们已经离开后，每个账单支付或每个工资被添加的金额。
Option Explicit Sub CreateList() ' Clear the current records Dim currentRow As Integer '<<always declare variables currentRow = 2 While currentRow < 200 And Not IsEmpty(Worksheets("Jan").Cells(currentRow, 9)) '<<best to not use goto unless no other way of coding it Worksheets("Jan").Cells(currentRow, 9).Value = "" Worksheets("Jan").Cells(currentRow, 10).Value = "" Worksheets("Jan").Cells(currentRow, 11).Value = "" currentRow = currentRow + 1 Wend ' Generate new list Dim titleCol As Integer, dayCol As Integer, amountCol As Integer, cellVal As String Dim currentListRow As Integer, currentSheet As Integer titleCol = 1 dayCol = 2 amountCol = 3 currentListRow = 3 currentSheet = 1 While currentSheet < 2 currentRow = 7 While currentRow < 800 cellVal = Worksheets("Jan").Cells(currentRow, dayCol).Text If Not IsEmpty(cellVal) And Not cellVal = "0" And Not cellVal = "" And Not cellVal = "Due Date" Then ' Set vals in list cells Worksheets("Jan").Cells(currentListRow, 10).Value = Worksheets("Jan").Cells(currentRow, dayCol).Text Worksheets("Jan").Cells(currentListRow, 9).Value = Worksheets("Jan").Cells(currentRow, titleCol).Text Worksheets("Jan").Cells(currentListRow, 11).Value = Worksheets("Jan").Cells(currentRow, amountCol).Text currentListRow = currentListRow + 1 End If currentRow = currentRow + 1 Wend currentSheet = currentSheet + 1 Wend Call Sort End Sub Public Sub Sort() Dim oneRange As Range Dim aCell As Range Set oneRange = Range("I3:K40") Set aCell = Range("J3") oneRange.Sort Key1:=aCell, Order1:=xlAscending, Header:=xlGuess Call Negative End Sub Public Sub Negative() Dim titlesCol As Integer, daysCol As Integer, amountsCol As Integer, cellVal As String Dim currentListRow As Integer, currentSheet As Integer, currentRow As Integer titlesCol = 9 amountsCol = 11 currentListRow = 3 currentSheet = 1 While currentSheet < 2 currentRow = 3 cellVal = "" While currentRow < 41 cellVal = Worksheets("Jan").Cells(currentRow, titlesCol).Text If Not cellVal = "Alisa" Then If Not cellVal = "Jordan" Then ' Multiply by Negative 1 Worksheets("Jan").Cells(currentRow, 11).Value = Worksheets("Jan").Cells(currentRow, 11).Value * -1 currentListRow = currentListRow + 1 End If End If currentRow = currentRow + 1 Wend currentSheet = currentSheet + 1 Wend End Sub
这是一个解决scheme，只需将该macros附加到工作表上的button即可。 我简单地logging了一个macros，然后将其修改为较less上下文特定的…
此解决scheme假定数据或标题在活动工作表的单元格A1中开始，并且不存在散布的空行或列。
如果要更改sorting列，只需将引用更改为“B”。
如果添加列，则将引用更改为“C”作为sorting区域中的最后一列，或者更好地更新代码以检测与我如何确定最后一行相似的所选范围内的最后一列。
祝你好运！
Public Sub SortByDescription() Dim Rng As Range, Ws As Excel.Worksheet, LastRow As Long Set Ws = ThisWorkbook.ActiveSheet Set Rng = Ws.Range("A1") Ws.Range(Rng, Rng.End(xlToRight)).Select Set Rng = Ws.Range(Selection, Selection.End(xlDown)) LastRow = Rng.End(xlDown).Row Ws.Sort.SortFields.Clear Ws.Sort.SortFields.Add Key:=Range("B1:B" & LastRow), _ SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal With Ws.Sort .SetRange Range("A1:C" & LastRow) .Header = xlGuess .MatchCase = False .Orientation = xlTopToBottom .SortMethod = xlPinYin .Apply End With Ws.Range("A1").Select End Sub
没有回答你的问题，但只是通过你的代码快速浏览，有几个明显的改进：
Option Explicit '<<best to use this in all modules; Sub CreateList() ' Clear the current records Dim currentRow As Integer '<<always declare variables currentRow = 2 While currentRow < 200 And Not IsEmpty(Worksheets("Jan").Cells(currentRow, 9)) '<<best to not use goto unless no other way of coding it Worksheets("Jan").Cells(currentRow, 9).Value = "" Worksheets("Jan").Cells(currentRow, 10).Value = "" Worksheets("Jan").Cells(currentRow, 11).Value = "" Worksheets("Jan").Cells(currentRow, 12).Value = "" currentRow = currentRow + 1 Wend ' Generate new list Dim titleCol As Integer, dayCol As Integer, amountCol As Integer Dim currentListRow As Integer, currentSheet As Integer titleCol = 1 dayCol = 2 amountCol = 3 currentListRow = 2 currentSheet = 1 While currentSheet < 2 currentRow = 7 cellVal = "" While currentRow < 800 cellVal = Worksheets("Jan").Cells(currentRow, dayCol).Text If Not IsEmpty(cellVal) And Not cellVal = "0" And Not cellVal = "" And Not cellVal = "Due Date" Then '<<all conditions seem to be able to go in one IF ' Set vals in list cells Worksheets("Jan").Cells(currentListRow, 10).Value = Worksheets("Jan").Cells(currentRow, dayCol).Text Worksheets("Jan").Cells(currentListRow, 9).Value = Worksheets("Jan").Cells(currentRow, titleCol).Text Worksheets("Jan").Cells(currentListRow, 11).Value = Worksheets("Jan").Cells(currentRow, amountCol).Text currentListRow = currentListRow + 1 End If currentRow = currentRow + 1 Wend currentSheet = currentSheet + 1 Wend Call SortByDescription End Sub Public Sub SortByDescription() Dim Rng As Range, Ws As Excel.Worksheet, LastRow As Long Set Ws = ThisWorkbook.ActiveSheet Set Rng = Ws.Range("A1") Ws.Range(Rng, Rng.End(xlToRight)).Select Set Rng = Ws.Range(Selection, Selection.End(xlDown)) LastRow = Rng.End(xlDown).Row Ws.Sort.SortFields.Clear Ws.Sort.SortFields.Add Key:=Range("B1:B" & LastRow), _ SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal With Ws.Sort .SetRange Range("A1:C" & LastRow) .Header = xlGuess .MatchCase = False .Orientation = xlTopToBottom .SortMethod = xlPinYin .Apply End With Ws.Range("A1").Select End Sub
Option Explicit行非常重要，您可以将编辑器设置为始终自动将此行包含在所有模块中。 当您在Tool菜单中的IDE中时，selectOptions并select检查“需要variables声明”
我已经将@Tahbaza例程添加到代码的底部 – 在底部的代码中，我添加了Call SortByDescription来调用sorting例程。
