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

Question

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

но мне неясно, как перевести это на 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

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

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

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