excel - 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

whytheqの助けを借りて、私はこの解決策を思いつきました。最初のSubは、フィールドを新しい領域にコピーします。2番目のサブは、新しく作成されたリストを日列で並べ替えます。3番目のサブは、新しく作成されたリストアイテムのうち、私の名前または妻の名前のラベルが付いていないものを変更し、それらをネガティブにします。これを行ったのは、新しいリストの右側にフィールドを追加して、各リストアイテムに関連付けられた計算を行い、各請求書の支払い後または各支払いの追加後に残っている金額を調整できるようにするためです。

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

あなたの質問に答えませんでしたが、あなたのコードをざっと見ただけで、いくつかの明らかな改善があります：

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されたら、[変数宣言が必要]を選択して選択します。ToolOptions

コードの下部に@Tahbazaルーチンを追加しました。また、下部のコードにCall SortByDescription、並べ替えルーチンを呼び出すために追加しました。

Answer 3

これが解決策です。ワークシートにドロップしたボタンにこのマクロを添付するだけです。私は単純にマクロを記録してから、文脈に依存しないように変更しました...

このソリューションでは、データまたはヘッダーがアクティブ シートのセル 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