Условное копирование из таблицы в Excel

Question

Я пытаюсь скопировать оба столбца дебета / кредита в другие таблицы, которые соответствуют только соответствующему значению счета, т.е. все денежные записи переходят в таблицу кассового счета и т.д. Мне также понадобится способ опустить те, которые уже были скопированы (поэтому необходимо указать какой-нибудь контрольный столбец).

но я не понимаю, как это перевести на VBA.

Вот наглядное изображение с рабочего листа:

И мой код VBA до сих пор (MyAdd - это функция, которая копирует диапазон в другую указанную таблицу)

Sub CopyRange()
For Each c In Range("Journal").Cells
 If c.Value = "Cash" Then
    If Range("Journal[@[Account 1]]").Value = "Cash" Then MyAdd "Cash_Account", Range(c.Offset(0, 2), c.Offset(0, 3))
    Else: MyAdd "Cash_Account", Range(c.Offset(0, 1), c.Offset(0, 2))
Next
End Sub

Answer 1

Используя решение Зака, я создал свое решение таким образом - на случай, если кто-то захочет следить за моей работой и улучшить ее:

Sub GetNewColumnOfData()

    Dim Table As ListObject
    Dim TargetRange As Range
    Dim Index As Long
    Dim Account As String

    Set Table = Range("Journal").ListObject

    For Index = 1 To Table.ListRows.Count
        If Not IsEmpty(Table.ListColumns("Account 1").DataBodyRange(Index, 1)) And IsEmpty(Table.ListColumns("*").DataBodyRange(Index, 1)) Then
            Account = Table.ListColumns("Account 1").DataBodyRange(Index, 1).Value
            Table.ListColumns("*").DataBodyRange(Index, 1).Value = "*"
            MyAdd Account, Range(Table.ListColumns("Debit").DataBodyRange(Index, 1), Table.ListColumns("Credit").DataBodyRange(Index, 1))
        ElseIf Not IsEmpty(Table.ListColumns("Account 2").DataBodyRange(Index, 1)) And IsEmpty(Table.ListColumns("*").DataBodyRange(Index, 1)) Then
            Account = Table.ListColumns("Account 2").DataBodyRange(Index, 1).Value
            Table.ListColumns("*").DataBodyRange(Index, 1).Value = "*"
            MyAdd Account, Range(Table.ListColumns("Debit").DataBodyRange(Index, 1), Table.ListColumns("Credit").DataBodyRange(Index, 1))
        End If
    Next Index

End Sub

Функция MyAdd была получена где-то еще на этом сайте, но я цитирую ее здесь для удобства:

Sub MyAdd(ByVal strTableName As String, ByRef arrData As Variant)
    Dim tbl As ListObject
    Dim NewRow As ListRow

    Set tbl = Range(strTableName).ListObject
    Set NewRow = tbl.ListRows.Add(AlwaysInsert:=True)

    ' Handle Arrays and Ranges
    If TypeName(arrData) = "Range" Then
        NewRow.Range = arrData.Value
    Else
        NewRow.Range = arrData
    End If
End Sub

Примечание. Я поместил этот код в модуль для Рабочей книги - и все диапазоны (таблицы / списки) по умолчанию являются именованными диапазонами Рабочей книги - следовательно, доступны без необходимости указывать листы, на которых они находятся.

Answer 2

Я не уверен, зачем вам это нужно. Казалось бы, есть еще одна конечная цель. Однако сделать то, что вы просите в VBA, можно с помощью приведенного ниже кода.

Sub GetNewColumnOfData()

    Dim Table As ListObject
    Dim TargetRange As Range
    Dim Index As Long
    Dim Values As Variant

    Set Table = ThisWorkbook.Worksheets("Sheet3").ListObjects("Journal")
    Set TargetRange = ThisWorkbook.Worksheets("Sheet3").Range("G1")
    ReDim Values(1 To Table.ListRows.Count, 1 To 1)

    For Index = 1 To Table.ListRows.Count
        If Table.ListColumns("Account 1").DataBodyRange(Index, 1).Value = "Cash" Then
            Values(Index, 1) = 1
        ElseIf Table.ListColumns("Account 2").DataBodyRange(Index, 1).Value = "Cash" Then
            Values(Index, 1) = 2
        End If
    Next Index

    TargetRange.Resize(Table.ListRows.Count, 1).Value = Values

End Sub

Определите соответственно имена диапазонов / таблиц.