4

Excelに銀行取引のエクスポートされたリストがあります。これをできるだけ早く簡単に分類したいと思います。これは配列数式だけで可能だと思いますが、VBA関数も同様に役立ちます。

シナリオ

私のスプレッドシートヘッダーは次のようになります。

| A    | B           | C      | D        |
==========================================
| Date | Description | Amount | Category |
------------------------------------------

日付、説明、金額は私の銀行から事前に入力されています。各トランザクションのカテゴリを列Dに入力します。

これは問題ありませんが、各カテゴリを個別に手動で入力する必要があるため、時間がかかります。

必要なもの

動的に生成および適用されるルールに基づいて、手動カテゴリを入力していない行にカテゴリを自動入力する必要があります。

必要な出力は次のようになります。

| A        | B             | C       | D           | E         | F           |
==============================================================================
| Date     | Description   | Amount  | Manual cat. | Rule      | Auto cat.   |
------------------------------------------------------------------------------
| 04/08/12 | Starbucks NYC |  -$5.42 | Coffee      | starbucks | Coffee      |
| 04/09/12 | Wal-Mart 468  | -$54.32 | Supermarket | wal-mart  | Supermarket |
| 04/10/12 | Starbucks SF  |  -$3.68 |             |           | Starbucks   |

ご覧のとおり、列Dに「手動」カテゴリを入力しました。これを行う場合は常に、列Eに分類「ルール」を入力しました。Excelは入力を使用して列Fを自動入力します。

ロジックは単純です。

  • 手動カテゴリに入ると、Excelは2つのことを行います。

    1. 列Fに手動カテゴリを入力します。
    2. 列Eに入力されたテキストを使用してルールを作成します。
  • Excelが、私のルールの1つで使用されているテキストを含む説明に出くわした場合、列Fの関連するカテゴリにデータを入力します。

利益

これにより、トランザクションのリストを簡単に整理し、カテゴリと関連するルールを追加できます。カテゴリのないトランザクションは、ルールが適用される場合は自動入力され、ルールが適用されない場合は空白のままになります。間違ったカテゴリを与えるルールが適用されたトランザクションは修正され、新しいルールが提供される可能性があります。

これまでの私の最善の試み

数式のみを使用してこれを行う方法を作成しましたが、3つの欠点があります。

  1. トランザクションと同じ数の列を作成する必要があります。
  2. カテゴリと関連するルールを一覧表示する便利な方法はありません。
  3. ルールが適用される順序を変更する方法はありません。
4

4 に答える 4

1

序章

前に示したように、以下のソリューションは、

それはあなたがあなたの質問にリストするものよりも多様な私のニーズのために設計されています:

  • 私は銀行を変更している最中なので、2つの現在の(当座預金)口座と2つのクレジットカード口座を持っています。普通預金口座もたくさんあります。私は、いくつかのワークブックにわたって、形式が異なるこれらすべてのアカウントの電子明細書を保持しています。
  • あなたの例のステートメントは、私が受け取るものと比較して非常にきちんとしています。これらは、私が「組織名、場所」の好ましい形式に整理した最近のMasterCardステートメントからのいくつかの説明です。

SAINSBURY'S S/MKT MONKS CROSS
Amazon *Mktplce EU-UK AMAZON.CO.UK LUX
WRAP LOUGHBOROUGH
SAINSBURYS PETROL MONKS CROSS
  • あなたのように私はトランザクションを分類します。
  • 一部の組織は、毎年事前に請求するか、四半期ごとに事前に請求するか、延滞します。私の収入は月ごとに異なります。これらの取引については、適切な月に金額を配分して、結果が私の実際の財政状況をよりよく反映するようにします。

これらの複数の要件に対する私の解決策は、アカウントごとに、それがどこにあり、各列が何に使用されているかを知っている制御ルーチンを用意することです。これらは、ワークブックやワークシートなどをパラメーターとして受け入れ、必要な変換と追加を実行する一般的なルーチンを呼び出します。これらの変換と追加の中心には、3つの列を持つ「ルール」と呼ばれるワークシートがあります。

RuleType       A code such as "OrgCat" 
In-keyword     A string, such as "Starbucks", to be found in a text column
Out-keyword    A string, such as "Coffee", to be returned if the In-keyword
               is found

私が使用する他のルールタイプは次のとおりです。

"OrgOrg"   Convert an organisation name used in the source statement to my
           preferred name for the organisation.
"CatPer"   Return a code identifying the apportioning rule for a category. For
           example, "Utility" returns "B3" (Back 3) because my utility bills
           are issued for three months in arrears.

あなたの質問では、あなたはあなたのアカウントの「シーンリオバージョン」とあなたのアカウントの「必要なバージョン」を持っています。アカウントの「必要なバージョン」を手動で作成して、どのように表示されるかを確認できると思います。アカウントの「必要なバージョン」を処理し、「OrgCat」タイプのルールを検証および抽出するマクロCopyFromAcctToRule()を提供しました。エラーが見つからない場合は、抽出したルールをワークシート「ルール」に出力し、「必要なバージョン」を「シーンリオバージョン」に変換します。「必要なバージョン」を作成していない場合、最も簡単なアプローチは、次のような部分的な「必要なバージョン」を作成することだと思います。

| A        | B             | C       | D           | E         |
================================================================
| Date     | Description   | Amount  | Category    | Rule      |
| 04/08/12 | Starbucks NYC |  -$5.42 | Coffee      | Starbucks |
| 04/09/12 | Wal-Mart 468  | -$54.32 | Supermarket | Wal-Mart  |
| 04/10/12 | Starbucks SF  |  -$3.68 |             |           |
| 04/11/12 | Wal-Mart 512  |-$123.45 |             |           |

つまり、最初のスターバックスを見つけて、そのカテゴリとルールを入力します。最初のウォルマートを見つけて、そのカテゴリとルールを入力します。等々。CopyFromAcctToRule()を実行すると、不整合や見逃した組織のエラーメッセージが「G」列に表示されます。1回限りの場合は、カテゴリに入力しますが、ルールは空のままにします。エラーが検出されてワークシート「Rule」が作成されるまで、エラーを修正してCopyFromAcctToRule()を実行します。注:不足しているカテゴリは、この段階では追加されません。それは以下で起こります。

「scenerioversion」アカウントのCategory列に入力して、マクロFillDerivedCol()を使用する方法のデモンストレーションを提供しました。部分的な「必要なバージョン」を作成したくない場合は、FillDerivedCol()が代替アプローチを提供します。説明のカテゴリが見つからない場合は、ワークシート「ルール」の下部に説明をコピーします。たとえば、スターバックスに対するルールのスペルを間違えた場合、「ルール」は次のように修正されます。

| A        | B             | C            |
===========================================
| Type     | In keyword    | Out keyword  |
| OrgCat   | Sarbucks      | Coffee       |
| OrgCat   | Wal-Mart      | Supermarket  |
| OrgCat   | Starbucks NYC |              |
| OrgCat   | Starbucks SF  |              |              

つまり、スターバックスのブランチごとに1つの新しい行があります。ここで、最も簡単なアプローチは、Sarbucks行を修正し、新しい行を削除することです。ただし、新しい組織の場合は、In-keywordを編集してブランチ情報を削除し、[Out-keyword]列にカテゴリを入力することができます。警告:回答の上限が30,000文字を超えました。診断コードを削除するには、これらのルーチンを編集する必要がありました。これを行っている間、エラーが発生していないことを願っています。

これがお役に立てば幸いです。幸運を祈ります。

グローバル

これらのグローバル定数とルーチンは、上記の両方のマクロで使用されます。私はそれらを独自のモジュールに配置しますが、それはあなたの選択です。

Option Explicit
  ' I use constant for objects such as column numbers which are fixed
  ' for long periods but which might change. Any code using a column
  ' that has moved can be updated by changing the constant.
  Public Const ColRuleType As Long = 1
  Public Const ColRuleKeywordIn As Long = 2
  Public Const ColRuleKeywordOut As Long = 3
  Public Const ColRuleLast As Long = 3
  Public Const RowRuleDataFirst As Long = 2

  ' Rules are accumulated in this array by CopyFromAcctToRule
  ' Rules are loaded to this array by UpdateNewTransactions
  ' See GetRuleDetails() for a description of this array.
  Public RuleData() As Variant
Public Sub GetRuleDetails(ByVal RuleType As String, ByVal SrcText As String, _
                          ByRef KeywordIn As String, ByRef KeywordOut As String, _
                          Optional ByRef RowRuleSrc As Long)

  ' This routine performs a case-insensive search of a list of in-keywords for
  ' one that is present in SrcText.  If one is found, it returns the in-keyword
  ' and the matching out-keyword.

  ' This routine uses the previously prepared array RuleData.  Since RuleData
  ' is to be loaded to, or has been loaded from, a worksheet, the first
  ' dimension is for the rows and the second dimension is for the columns.

  ' RuleData has three columns:
  '  * RuleType: a code identifying a type of rule.  Only rows in RuleData for
  '    which this column matches the parameter RuleType will be considered.
  '  * KeywordIn: a string.  The first row in RuleData where the value of this
  '    column is contained within parameter SrcText is the selected Rule.
  '  * KeywordOut: a string.

  ' Input parameters
  '  * RuleType: Foe example, the rule type "OrgCat" will return a
  '    category for an organisation.
  '  * SrcText: The text field to be searched for the in keyword.

  ' Output parameters
  '  * KeywordIn: The value from the KeywordIn column of RuleData for the first
  '    row of RuleData of the required RuleType for which the KeywordIn value can
  '    be found in Desc.  The value in SrcText may be of any case although it is
  '    likely to be capitalised.  This value is the preferred display value.
  '  * KeywordOut: The value from the KeywordOut column of RuleData of the
  '    selected row.  For this routine, KeywordOut is a string with no
  '    significance.  It is the calling routine that understands the rule type.
  '  * RowRuleSrc: Only used during build of RuleData so the caller can access
  '    non-standard data held in RuleData during build.

  Dim LCSrcText As String
  Dim RowRuleCrnt As Long

  LCSrcText = LCase(SrcText)
  For RowRuleCrnt = RowRuleDataFirst To UBound(RuleData, 1)
    If RuleData(RowRuleCrnt, ColRuleKeywordIn) = "" Then
      ' Empty row.  This indicated end of table during build
      KeywordIn = ""
      KeywordOut = ""
      Exit Sub
    End If
    If RuleType = RuleData(RowRuleCrnt, ColRuleType) Then
      ' This row is for the required type of rule
      If InStr(1, LCSrcText, _
                  LCase(RuleData(RowRuleCrnt, ColRuleKeywordIn))) <> 0 Then
        ' Have found first rule with KeywordIn contained within SrcText
        KeywordIn = RuleData(RowRuleCrnt, ColRuleKeywordIn)
        KeywordOut = RuleData(RowRuleCrnt, ColRuleKeywordOut)
        If Not IsEmpty(RowRuleSrc) Then
          RowRuleSrc = RowRuleCrnt
        End If
        Exit Sub
      End If
    End If
  Next
  ' No rule found
  KeywordIn = ""
  KeywordOut = ""

End Sub

ルールを抽出し、アカウントをNeedからScenerioスタイルに変換します

このルーチンの使用方法の詳細については、「はじめに」を参照してください。既存のトランザクションのワークシート「ルール」を作成すると、このコードはおそらくそれ以上の価値がなくなります。使用後にアーカイブおよび削除できるように、独自のモジュールに配置します。このコードは、ワークシート「Rule」と「Matt'sAcct」が同じワークブックにあることを前提としています。アカウントのコピーを作成し、ワークシート「Rule」を作成してから、コピーアカウントでCallCopyFromAcctRule()を実行して、結果を評価することをお勧めします。警告:「キーワード内」を使用する場合は「ルール」を使用します。コメントとエラーメッセージの一貫性を保つように努めましたが、一貫性があることを保証することはできません。

Option Explicit
Sub CallCopyFromAcctRule()

  ' This routine exists simply to make it easy to change the names of the
  ' worksheets accessed by CallCopyFromAcctRule.

  Call CopyFromAcctToRule("Rule", "Matt's Acct")

End Sub
Sub CopyFromAcctToRule(ByVal Rule As String, ByVal Acct As String)

  ' * This routine builds the worksheet Rule from worksheet Acct.
  ' * It works down worksheet Acct extracting rules from rows where
  '   there is both a Rule and a Category.  Note: this routine does not
  '   distinguish between Manual and Automatic Categories although, if both are
  '   present, they must be the same.
  ' * The routine checks for a variety of error and possible error conditions.
  '   Error and warning messages are placed in columns defined by ColAcctError
  '   and ColAcctWarn.
  ' * If any errors are found, the routine does not change either worksheet
  '   Acct, apart from adding error messages, or worksheet Rule.
  ' * If no errors are found, worksheet Rule is cleared and the contents of
  '   RuleData written to it.
  ' * If no errors are found, any warning added to worksheet Acct are discarded
  '   and the following additional changes made:
  '    * The values in the Automatic category column are merged into the Manual
  '      category column which is relabelled "Category".
  '    * The Rule and Automatic category columns are cleared.

  Dim ColAcctCatAuto As Long
  Dim ColAcctCatMan As Long
  Dim ColAcctCrnt As Long
  Dim ColAcctDesc As Long
  Dim ColAcctError As Long
  Dim ColAcctRule As Long
  Dim ColAcctWarn As Long
  Dim ColRuleRowSrc As Long
  Dim DescCrnt As String
  Dim ErrorFoundAll As Boolean
  Dim ErrorFoundCrnt As Boolean
  Dim KeywordInCrnt As String
  Dim KeywordInRetn As String
  Dim KeywordOutCrnt As String
  Dim KeywordOutRetn As String
  Dim RowAcctCrnt As Long
  Dim RowAcctDataFirst As Long
  Dim RowAcctLast As Long
  Dim RowRuleCrntMax As Long
  Dim RowRuleSrc As Long

  ' These column values must be changed if the true value do not match those
  ' in the example in the question.
  ColAcctDesc = 2
  ColAcctCatMan = 4
  ColAcctRule = 5
  ColAcctCatAuto = 6
  ColAcctError = 8
  ColAcctWarn = 9
  ColRuleRowSrc = ColRuleLast + 1
  RowAcctDataFirst = 2

  With Worksheets(Acct)
    RowAcctLast = .Cells.SpecialCells(xlCellTypeLastCell).Row

    ' Size the array for the output data ready to be loaded to worksheet
    ' Rule with rows as the first dimension.  Allow for the maximum number of
    ' rows because an array cannot be resized to change the number of
    ' elements in the first dimension.  Allow an extra column for use during
    ' the build process.
    ReDim RuleData(1 To RowAcctLast, 1 To ColRuleRowSrc)
    RuleData(1, ColRuleType) = "Type"
    RuleData(1, ColRuleKeywordIn) = "In keyword"
    RuleData(1, ColRuleKeywordOut) = "Out keyword"
    RowRuleCrntMax = 1      ' Last currently used row

    With .Cells(1, ColAcctError)
      .Value = "Error"
      .Font.Bold = True
    End With
    With .Cells(1, ColAcctWarn)
      .Value = "Warning"
      .Font.Bold = True
    End With

    ErrorFoundAll = False
    For RowAcctCrnt = RowAcctDataFirst To RowAcctLast
      .Cells(RowAcctCrnt, ColAcctError).Value = ""  ' Clear any error or warning
      .Cells(RowAcctCrnt, ColAcctWarn).Value = ""   ' from previous run
      ErrorFoundCrnt = False
      ' Determine Category, if any
      If .Cells(RowAcctCrnt, ColAcctCatMan).Value = "" Then
        ' There is no manual category.
        If .Cells(RowAcctCrnt, ColAcctCatAuto).Value <> "" Then
          KeywordOutCrnt = .Cells(RowAcctCrnt, ColAcctCatAuto).Value
        Else
          ' Neither manual nor automatic category
          KeywordOutCrnt = ""
        End If
      Else
        ' There is a manual category.  Is it consistent with automatic category?
        KeywordOutCrnt = .Cells(RowAcctCrnt, ColAcctCatMan).Value
        If .Cells(RowAcctCrnt, ColAcctCatAuto).Value <> "" Then
          ' Automatic category exists.  It must be the same
          ' as the manual category to be valid.
          If LCase(KeywordOutCrnt) <> _
                             LCase(.Cells(RowAcctCrnt, ColAcctCatAuto).Value) Then
            ErrorFoundCrnt = True
            .Cells(RowAcctCrnt, ColAcctError).Value = _
                                       "Manual and automatic categories different"
          End If
        End If
      End If
      If Not ErrorFoundCrnt Then
        ' Match Rule, if any, against Category, if any
        KeywordInCrnt = .Cells(RowAcctCrnt, ColAcctRule).Value
        If KeywordInCrnt <> "" Then
          ' This row has keyword
          If KeywordOutCrnt = "" Then
            ' Rule but no Category
            DescCrnt = .Cells(RowAcctCrnt, ColAcctDesc).Value
            Call GetRuleDetails("OrgCat", DescCrnt, KeywordInRetn, KeywordOutRetn)
            If KeywordInRetn <> "" Then
              ' Rule found that would generate a category for this Keyword.
              ' No warning necessary
            Else
              ' No rule found that would generate a category for this keyword
              ErrorFoundCrnt = True
              .Cells(RowAcctCrnt, ColAcctError).Value = _
                            "There is no existing rule that would " & _
                            "generate a Category from this Rule"
            End If
          Else
            ' Both Rule and Category found
            ' Is match already recorded?
            DescCrnt = .Cells(RowAcctCrnt, ColAcctDesc).Value
            Call GetRuleDetails("OrgCat", DescCrnt, KeywordInRetn, _
                                                   KeywordOutRetn, RowRuleSrc)
            If KeywordInRetn <> "" Then
              If KeywordInCrnt <> KeywordInRetn Then
                ' A different rule would be applied to this Description
                If InStr(1, LCase(DescCrnt), LCase(KeywordInCrnt)) = 0 Then
                  ' The current Rule is not within the Description
                  ErrorFoundCrnt = True
                  .Cells(RowAcctCrnt, ColAcctError).Value = _
                      "The Rule in column " & Chr(64 + ColAcctRule) & _
                      " is not within the Description.  The Rule " & _
                      "from row " & RowRuleSrc & " would generate " & _
                      "the required Category '" & KeywordOutRetn & _
                      "' from this Description"
                Else
                  ' The current Rule is within the Description
                  If LCase(KeywordOutRetn) = LCase(KeywordOutCrnt) Then
                    ' It would generate the same category
                    ErrorFoundCrnt = True
                    .Cells(RowAcctCrnt, ColAcctError).Value = _
                      "The Rule in column " & Chr(64 + ColAcctRule) & _
                      " is within the Description but the Rule from " & _
                      "row " & RowRuleSrc & " would be selected to " & _
                      "generate the required Category '" & _
                      KeywordOutRetn & "' from this Description"
                  Else
                    ' It would generate a different category
                    ErrorFoundCrnt = True
                    .Cells(RowAcctCrnt, ColAcctError).Value = _
                      "The Rule in column " & Chr(64 + ColAcctRule) & _
                      " is within the Description but the Rule from " & _
                      "row " & RowRuleSrc & " would be selected to " & _
                      "generate Category '" & KeywordOutRetn & _
                      "', not Category '" & KeywordOutCrnt & _
                      "', from this " & "Description"
                  End If
                End If
              Else
                ' Rule already recorded
                If LCase(KeywordOutRetn) = LCase(KeywordOutCrnt) Then
                  ' Rule already recorded for this category. No action required.
                Else
                  ' Rule already recorded but not for this category
                  ErrorFoundCrnt = True
                  .Cells(RowAcctCrnt, ColAcctError).Value = _
                                "The rule from row " & RowRuleSrc & _
                                " would generate category """ & _
                                KeywordOutRetn & """ for this Rule"
                End If
              End If
            Else
              ' New rule
              RowRuleCrntMax = RowRuleCrntMax + 1
              RuleData(RowRuleCrntMax, ColRuleType) = "OrgCat"
              RuleData(RowRuleCrntMax, ColRuleKeywordOut) = KeywordOutCrnt
              RuleData(RowRuleCrntMax, ColRuleKeywordIn) = KeywordInCrnt
              RuleData(RowRuleCrntMax, ColRuleRowSrc) = RowAcctCrnt
            End If
          End If  ' If CatCrnt = ""
        Else
          ' No keyword
          If KeywordOutCrnt = "" Then
            ' No Keyword and no Category
            DescCrnt = .Cells(RowAcctCrnt, ColAcctDesc).Value
            If DescCrnt = "" Then
              ' Probably a blank line.  Ignore
            Else
              ' Would an existing rule generate a Category for Description
              Call GetRuleDetails("OrgCat", DescCrnt, KeywordInRetn, KeywordOutRetn)
              If KeywordInRetn = "" Then
                ' No rule found that would generate a category
                ' for this description
                .Cells(RowAcctCrnt, ColAcctError).Value = _
                          "There is no rule that would generate " & _
                          "a Category from this Description"
              Else
                ' Rule found that would generate a category for
                ' this description.
              End If
            End If
          Else
            ' No Keyword but have Category
            ' Check for a rule that would give current category
            ' from current description
            DescCrnt = .Cells(RowAcctCrnt, ColAcctDesc).Value
            Call GetRuleDetails("OrgCat", DescCrnt, KeywordInRetn, _
                                                   KeywordOutRetn, RowRuleSrc)
            If KeywordInRetn <> "" Then
              ' Have found a rule for the description
              If LCase(KeywordOutRetn) = LCase(KeywordOutCrnt) Then
                ' Rule generates current category
              Else
                ' Rule does not generate current category
                ErrorFoundCrnt = True
                .Cells(RowAcctCrnt, ColAcctError).Value = _
                     "The rule from row " & RuleData(RowRuleSrc, ColRuleRowSrc) & _
                     " would generate Category '" & KeywordOutRetn & _
                     "' from this Description"
              End If
            Else
              ' There is no rule for this Description.  This is not necessarily
              ' an error.  The category may have to be set manually.
              .Cells(RowAcctCrnt, ColAcctWarn).Value = _
                            "There is no rule that would generate " & _
                            "this Category from this Description"
            End If
          End If    ' If KeywordOutCrnt = ""
        End If      ' KeywordInCrnt <> ""
      End If  ' If Not ErrorFoundCrnt
      If ErrorFoundCrnt Then
        ErrorFoundAll = True
      End If
    Next
  End With

  If ErrorFoundAll Then
     Exit Sub
  End If

  ' No errors found

  ' Clear existing contents from worksheet Rule and load with RuleData
  With Worksheets(Rule)
    .Cells.EntireRow.Delete
    .Range(.Cells(1, 1), .Cells(RowRuleCrntMax, _
                                        ColRuleKeywordOut)).Value = RuleData
    .Range("A1:C1").Font.Bold = True
    .Columns.AutoFit
  End With

  With Worksheets(Acct)
    ' Merge values from automatic category column into manual category column
    For RowAcctCrnt = 2 To RowAcctLast
      If .Cells(RowAcctCrnt, ColAcctCatMan).Value = "" Then
        ' There is no manual category so set to automatic category.
        .Cells(RowAcctCrnt, ColAcctCatMan).Value = _
                                    .Cells(RowAcctCrnt, ColAcctCatAuto).Value
      End If
    Next
    ' Clear automatic category
    .Columns(ColAcctCatAuto).ClearContents
    ' Change column heading
    With .Cells(1, ColAcctCatMan)
      .Value = "Category"
      .Font.Bold = True
    End With
    ' Clear Error and Warning columns
    .Columns(ColAcctError).ClearContents   ' Only heading to clear
    .Columns(ColAcctWarn).ClearContents
    ' Clear Rule column
    .Columns(ColAcctRule).ClearContents
  End With

End Sub

シーンリオバージョンアカウントのカテゴリ列に入力する

これは、新しいトランザクションの[カテゴリ]列に入力する方法を示しています。

Option Explicit
Sub CallFillDerivedCol()

  ' I use FillDerivedCol() on worksheets loaded with transactions for different
  ' accounts.  They are in different workbooks, different worksheets and have
  ' different columns.  This routine exists to call FillDerivedCol() for my
  ' test version of your account

  Call FillDerivedCol(ActiveWorkbook, "Rule", _
                      ActiveWorkbook, "Matt's Acct", "OrgCat", 2, 4)

  ' For this example, I had the rules and the account in same workbook.  To
  ' have them in different workbooks, as I normally do, you will need something
  ' like:

  '  Dim PathCrnt As String
  '  Dim WBookOrig As Workbook
  '  Dim WBookOther As Workbook

  '  Set WBookOrig = ActiveWorkbook
  '  PathCrnt = ActiveWorkbook.Path & "\"
  '  Set WBookOther = Workbooks.Open(PathCrnt & "xxxxxxx")

  '  Call FillDerivedCol(WBookOrig, "Rule", _
  '                      WBookOther, "Matt's Acct", "OrgCat", 2, 4)

  '  WBookOther.Close SaveChanges:=True

End Sub
Sub FillDerivedCol(ByVal WBookRule As Workbook, ByVal WSheetRule As String, _
                   ByVal WBookTrans As Workbook, ByVal WSheetTrans As String, _
                   ByVal RuleType As String, _
                   ByVal ColSrc As Long, ByVal ColDest As Long)

  ' Fill any gaps in WBookTrans.Worksheets(WSheetTrans).Columns(ColDest) based on
  ' rules in worksheet WBookRule.Worksheets(WSheetRule).

  ' WBook.Worksheets(WSheetTrans).Columns(ColSrc) is a text field which
  ' contains in-keywords.  Rules of type RuleType convert in-keywords to
  ' out-keywords which are the values required for .Columns(ColDest).

  Dim CellEmptyDest As Range
  Dim KeywordIn As String
  Dim KeywordOut As String
  Dim MissingRule() As Variant
  Dim RowAcctCrnt As Long
  Dim RowAcctPrev As Long
  Dim RowMissingCrntMax As Long
  Dim RowRuleLast As Long

  ' Load array RuleData from worksheet Rule
  With WBookRule.Worksheets(WSheetRule)
    RowRuleLast = .Cells(Rows.Count, 1).End(xlUp).Row
    RuleData = .Range(.Cells(1, 1), .Cells(RowRuleLast, ColRuleLast)).Value
  End With

  ' * Prepare MissingRule() in case any calls to GetRuleDetails() fails to
  '   find a known in-keyword in WBook.Worksheets(WSheetName).Columns(ColDest).
  ' * The number of occurrences of the first dimension cannot be changed. 500
  '   is intended to be more occurrences than could possible be needed. If
  '   more than 500 missing rules are found, only the first 500 will be added
  '   to worksheet "Rule"  This routine can be immediately run again to add
  '   another 500 missing rules.
  ReDim MissingRule(1 To 500, 1 To ColRuleLast)
  RowMissingCrntMax = 0

  With WBookTrans
    With .Worksheets(WSheetTrans)
      RowAcctPrev = 1
      ' Find the next empty cell in column ColDest for a transaction row
      Set CellEmptyDest = .Columns(ColDest).Find(What:="", _
                      After:=.Cells(RowAcctPrev, ColDest), LookIn:=xlFormulas, _
                      LookAt:=xlWhole, SearchOrder:=xlByRows, _
                      SearchDirection:=xlNext, MatchCase:=False, _
                      SearchFormat:=False)
      Do While True
        If CellEmptyDest Is Nothing Then
          ' No empty cell found in column.  This is not a realistic situation
          ' because it would require every row in the worksheet to have a value.
          Exit Do
        End If
        RowAcctCrnt = CellEmptyDest.Row
        If RowAcctCrnt < RowAcctPrev Then
          ' Have looped back to the top.  This is not a realistic situation
          ' because it would require every row in the worksheet to have a value.
          Exit Do
        End If
        If .Cells(RowAcctCrnt, ColSrc).Value = "" Then
          ' This row has no value in either the source or the destination
          ' columns.  Assume all transactions finished
          Exit Do
        End If
        Call GetRuleDetails(RuleType, .Cells(RowAcctCrnt, ColSrc).Value, _
                                                          KeywordIn, KeywordOut)
        If KeywordIn = "" Then
          ' No in-keyword found within source column.  Add source column value
          ' to MissingData for user to edit.
          If RowMissingCrntMax >= UBound(MissingRule, 1) Then
            ' All available rows in MissingRule already used
          Else
            RowMissingCrntMax = RowMissingCrntMax + 1
            MissingRule(RowMissingCrntMax, ColRuleType) = RuleType
            MissingRule(RowMissingCrntMax, ColRuleKeywordIn) = _
                                              .Cells(RowAcctCrnt, ColSrc).Value
          End If
        Else
          .Cells(RowAcctCrnt, ColDest).Value = KeywordOut
        End If
        RowAcctPrev = RowAcctCrnt
        Set CellEmptyDest = .Columns(ColDest).FindNext(CellEmptyDest)
      Loop
    End With
  End With

  If RowMissingCrntMax > 0 Then
    ' Transactions found for which no rule exists.  Add to worksheet "Rule"
    ' for attention by the user.
    With WBookRule.Worksheets(WSheetRule)
      RowRuleLast = .Cells(Rows.Count, 1).End(xlUp).Row
      .Range(.Cells(RowRuleLast + 1, 1), _
             .Cells(RowRuleLast + RowMissingCrntMax, ColRuleLast)).Value _
                                                                 = MissingRule
    End With
  End If

End Sub
于 2012-04-15T20:20:14.950 に答える
0

私は自分のクレジットカードの明細書と同じようなことをします。説明に一貫性がなく、分類するためにさまざまな手法が必要なため、VBAを使用します。

私が使用するアプローチは、ルールと呼ばれるワークシートに次のものを含めることです。

Organisation     Category
Starbucks NYC    Coffee shop
Starbucks SF     Coffee shop
Wal-Mart 468     Supermarket

注意してください、私はブランチごとに行を持っています。あなたがたくさん旅行するならこれは苦痛ですが、一貫性がなければ選択肢はほとんどありません。

ステートメントの列Dに入力=VLOOKUP(B2,Rule!A:B,2,FALSE)して、これをコピーします。

毎月、新しい組織は「#N/A」に分類されます。1回限りの分類を入力するか、組織をワークシートルールに追加します。

于 2012-04-08T13:22:52.237 に答える