Excel基于其他单元格创建排序列表

Question

我想要做的是拿出我的预算表并按特定顺序对其进行排序。这正是我所拥有的：

A栏=预算项目的名称（账单和支付）

B列=项目到期月份的日期。

C列=项目所用的金额。

我想创建一些VBA代码，当按下某个按钮时，它会从这些列中获取该信息，然后在B列中按日排序：

1 - PayDay - 1000
4 - Cell Phone - 75
5 - Mortgage - 1350

编辑：

我一直在研究这个VBA。只需要弄清楚如何输入sort函数，以便按日列命令我的结果。

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

Answer 1

在为什么theq的帮助下，我提出了这个解决方案。第一个Sub将字段复制到新区域。第二个子按日列对新创建的列表进行排序。第三个子更改任何未标记为我的或我的妻子名称的新创建的列表项，并使它们为负。我这样做了所以我可以在新列表的右侧添加一个字段，该字段与每个列表项相关联，调整每个账单支付或每次支付后我们留下的金额。

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

Answer 2

这是一个解决方案，只需将此宏附加到您放在工作表上的按钮即可。 我只是记录了一个宏，然后将其修改为更少的特定于上下文......

此解决方案假设数据或标题从活动工作表的单元格A1开始，并且没有散布的空行或列。

如果要更改排序列，只需将引用更改为“B”。

如果添加列，请将对“C”的引用更改为排序区域中的最后一列，或者更好的是，更新代码以检测所选范围中的最后一列，类似于我确定最后一行的方式...

祝你好运！

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

Answer 3

没有回答你的问题，但只是快速浏览一下代码，并且有一些明显的改进：

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行非常重要，您可以将编辑器设置为始终在所有模块中自动包含此行。当您在IDE菜单中的Tool时，选择Options并选择检查＆＃34;需要变量声明＆＃34;

我已将@Tahbaza例程添加到代码的底部 - 在底部的代码中，我已添加Call SortByDescription来调用排序例程。