VBA Копирование данных из одной таблицы в другую и перестановка столбцов

Question

У меня есть 99 столбцов в одной таблице с именем tbl_raw.Мне нужно скопировать 96 из этих столбцов в другую таблицу с такими же точными именами заголовков, но они расположены в другом порядке.Какой самый эффективный способ сделать это?

Единственный способ, которым я знал, был:

raw_data.Range("tbl_raw[EMPLOYEE]").Copy processed_data.Range("tbl_processed[EMPLOYEE]").PasteSpecial

Однако, это заняло бы много кода (96 * 2 = 192 строки), и я не былконечно, если есть более эффективный способ сделать это.

Я пытался использовать https://www.thespreadsheetguru.com/blog/2014/6/20/the-vba-guide-to-listobject-excel-tables,, но я также не мог найти способ сделать это с этой информацией.

Любое руководство будет с благодарностью.

Answer 1

Избегайте копирования столбцов ListObject и используйте прямую передачу значений.

Option Explicit

Sub raw2processed()

    Dim lc As Long, mc As Variant, x As Variant
    Dim raw_data As Worksheet, processed_data As Worksheet
    Dim raw_tbl As ListObject, processed_tbl As ListObject

    Set raw_data = Worksheets("raw")
    Set processed_data = Worksheets("processed")
    Set raw_tbl = raw_data.ListObjects("tbl_raw")
    Set processed_tbl = processed_data.ListObjects("tbl_processed")

    With processed_tbl
        'clear target table
        On Error Resume Next
        .DataBodyRange.Clear
        .Resize .Range.Resize(raw_tbl.ListRows.Count + 1, .ListColumns.Count)
        On Error GoTo 0

        'loop through target header and collect columns from raw_tbl
        For lc = 1 To .ListColumns.Count
            Debug.Print .HeaderRowRange(lc)
            mc = Application.Match(.HeaderRowRange(lc), raw_tbl.HeaderRowRange, 0)
            If Not IsError(mc) Then
                x = raw_tbl.ListColumns(mc).DataBodyRange.Value
                .ListColumns(lc).DataBodyRange = x
            End If
        Next lc

    End With

End Sub

Answer 2

ForEach / For - это магия работы с массивами и коллекциями. Есть способы сделать следующий код более эффективным, но я думаю, что это может помешать понять, что происходит. Прошло около 6 месяцев с тех пор, как я последний раз работал с VBA, но я считаю, что это должно сработать. Я предлагаю пройтись и посмотреть ваши местные жители, чтобы увидеть, что происходит. Если есть проблемы с присвоением переменных, может потребоваться изменить значение «Let» на «Set». Код следует:

'// PROBLEM:
'// Copy data from one list to a second list.
'// Both lists have the same column names and the same number of columns.
'// Copy data based on the column name.

'// Modify to return a custom source-destination association.
Private Function GetColumnTranslations(zLeftColumns As ListColumns, zRightColumns As ListColumns) As Variant
  Dim zReturn(,) As Variant
  ReDim zReturn(0 To zLeftColumns.Count As Long, 0 To 1 As Long)
  Dim zReturnOffset As Long '// Specifies what index we are working at during our ForEach interations.  

  Dim zLeftVar As Variant
  Dim zRightVar As Variant

  ForEach zLeftVar in zLeftColumns
    '// Go through each 'left' column to Find the first 'right' column that matches the name of the 'left' column.
    '// Only the first 'right' column with a matching name will be used. Issue is solved with another ForEach, but beyond forum question's scope.
    ForEach zRightVar in zRightColumns

      If zLeftVar.Name = zRightVar.Name Then

        '// Store the association and exit the nested ForEach.
        Let zReturn(zReturnOffset, 0) = zLeftVar.Range.Column '// Source.
        Let zReturn(zReturnOffset, 1) = zRightVar.Range.Column '// Destination.
        Let zReturnOffset = zReturnOffset + 1

        Exit ForEach
      End If
    Next zRightVar
  Next zLeftVar

  '// Assign return value.
  Let GetColumnTranslations = zReturn
End Function


'// Take each source row and copy the value to a new destination row.
'// New rows are added to the end of the destination list.
Public Sub CopyList(zSourceList As ListObject, zDestinationList As ListObject)
  Dim zColumnTranslations As Variant '// Will be 2-dimensional array.
  Dim zTranslationVar As Variant '// Will be array of 2 elements. 
  Let zColumnTranslations = GetColumnTranslations(zSourceList.Columns, zDestinationList.Columns)

  Dim zSourceRowVar As Variant '// Will translate to Range.
  Dim zDestinationRow As Range

  '// Every source row needs copied to a new row in destination.
  ForEach zSourceRowVar in zSourceList.Rows
    Set zDestinationRow = zDestinationList.Rows.Add.Range

    ForEach zTranslationVar in zColumnTranslations
      '// Value may copy formula.
      Let zDestinationRow(0,zTranslationVar(1)).Value = zSourceRowVar(0,zTranslationVar(0)).Value
    Next zTranslationVar
  Next zSourceRowVar
End Sub

Answer 3

Вот базовый пример копирования всех столбцов, кроме некоторых, из одной таблицы в другую:

Dim tbl1 As ListObject, tbl2 As ListObject
Dim h As ListColumn

Set tbl1 = ActiveSheet.ListObjects("Table1")
Set tbl2 = ActiveSheet.ListObjects("Table2")

'loop over the headers from the source table
For Each h In tbl1.ListColumns
    'is the column name in the "excluded" list?
    If IsError(Application.Match(h.Name, Array("col10", "col11"), 0)) Then

        'ok to copy...
        h.DataBodyRange.Copy tbl2.ListColumns(h.Name).DataBodyRange(1)

    End If
Next h