Excel創建基於其他單元格的分類列表

Question

我想要做的是拿我的預算表並按特定順序排序。這正是我：

列A =項目的名字預算（票據並支付）

列B =月的一天該項目到期。

C列=項目的用途。

我想創造一些VBA代碼，當按下一個按鈕，它會從那些列，並責令該信息由一天中的B欄是這樣的：

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

編輯：

我一直在研究這個VBA。只需要弄清楚如何放入排序函數，以便按日欄排序我的結果。

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

下面是一個解決方案，只需將該宏附加到工作表上的按鈕即可。 我簡單地記錄了一個宏，然後將其修改爲較少上下文特定的...

此解決方案假定數據或標題在活動工作表的單元格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 2

沒有回答你的問題，但剛剛通過您的代碼咋一看，有一對夫婦的明顯改善：

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選擇Options，選擇勾選「要求變量聲明」

我添加@Tahbaza例行程序代碼的底部 - 在你的代碼在我已經添加了底部Call SortByDescription調用排序例程。

Answer 3

隨着whytheq的幫助下，我想出了這個解決方案。第一個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