Скопируйте столбцы по именам заголовков и вставьте в другую книгу

Question

Получил этот VBA для копирования выбранных столбцов из источника по именам столбцов:

Sub CopyColumnsByName()

    Dim CurrentWS As Worksheet
    Set CurrentWS = ActiveSheet

    Dim SourceWS As Worksheet
    Set SourceWS = Workbooks("UTTREKK.xlsx").Worksheets(1)
    Dim SourceHeaderRow As Integer: SourceHeaderRow = 1
    Dim SourceCell As Range, sRange As Range, Rng As Range

    Dim TWS As ThisWorkbook
    Dim TargetWS As Worksheet
    Set TargetWS = Workbooks("Target.xlsm").Worksheets("data")
    Dim TargetHeader As Range
    Set TargetHeader = TargetWS.Range("A1:AX1")

    Dim RealLastRow As Long
    Dim SourceCol As Integer


'COPY AND PASTE COLUMNS

'Column: id
    SourceWS.Activate
    lastCol = Sheets(1).Cells(1, Columns.Count).End(xlToLeft).Column
    Set sRange = Sheets(1).Range("A1", Cells(1, lastCol))
    With sRange
        Set Rng = .Find(What:="id", _
                        After:=.Cells(1), _
                        LookIn:=xlValues, _
                        LookAt:=xlWhole, _
                        SearchOrder:=xlByRows, _
                        SearchDirection:=xlPrevious, _
                        MatchCase:=False)
        If Not Rng Is Nothing Then
            lastRow = Sheets(1).Cells(Rows.Count, Rng.Column).End(xlUp).Row
            Sheets(1).Range(Rng, Cells(lastRow, Rng.Column)).Copy
                TargetWS.Activate
                Sheets("data").Range("A1").PasteSpecial
        End If
    End With


'Column: sisteprosess
    SourceWS.Activate
    lastCol = Sheets(1).Cells(1, Columns.Count).End(xlToLeft).Column
    Set sRange = Sheets(1).Range("A1", Cells(1, lastCol))
    With sRange
        Set Rng = .Find(What:="sisteprosess", _
                        After:=.Cells(1), _
                        LookIn:=xlValues, _
                        LookAt:=xlWhole, _
                        SearchOrder:=xlByRows, _
                        SearchDirection:=xlPrevious, _
                        MatchCase:=False)
        If Not Rng Is Nothing Then
            lastRow = Sheets(1).Cells(Rows.Count, Rng.Column).End(xlUp).Row
            Sheets(1).Range(Rng, Cells(lastRow, Rng.Column)).Copy
                TargetWS.Activate
                Sheets("data").Range("B1").PasteSpecial
        End If
    End With


'Column: hendelse
    SourceWS.Activate
    lastCol = Sheets(1).Cells(1, Columns.Count).End(xlToLeft).Column
    Set sRange = Sheets(1).Range("A1", Cells(1, lastCol))
    With sRange
        Set Rng = .Find(What:="hendelse", _
                        After:=.Cells(1), _
                        LookIn:=xlValues, _
                        LookAt:=xlWhole, _
                        SearchOrder:=xlByRows, _
                        SearchDirection:=xlPrevious, _
                        MatchCase:=False)
        If Not Rng Is Nothing Then
            lastRow = Sheets(1).Cells(Rows.Count, Rng.Column).End(xlUp).Row
            Sheets(1).Range(Rng, Cells(lastRow, Rng.Column)).Copy
                TargetWS.Activate
                Sheets("data").Range("C1").PasteSpecial
        End If
    End With


End Sub

Он работает, но есть две проблемы, которые я не могу понять:

1. Как мне скопировать столбцы из строки 2 и до последней строки? Заголовки уже есть в моих целевых ячейках.

2. Мой VBA основан на повторении одного и того же бита кода для каждого столбца. Можно ли изменить это таким образом, чтобы я мог определять имена исходных столбцов и диапазон целевых столбцов вверху и запускать тот же код в l oop. Я не знаю, как написать такой код, но у меня 30+ столбцов, и копировать код 30 раз кажется пустой тратой ...

И в качестве бонуса: Мой код копирует данные в последнюю использованную строку для каждого столбца. Однако в некоторых столбцах есть пустые ячейки. Это не большая проблема, но можно ли установить «диапазон последней строки» для всех копируемых столбцов как последнюю строку в столбце A? Этот столбец содержит данные во всех 50 000 ячеек.

Answer 1

Определите массив с именами ваших столбцов ColumnNameList = Array("id", "sisteprosess", "hendelse"), а затем l oop через него.

Вам также понадобится счетчик PasteColumn, чтобы перейти к следующему столбцу для вставки в рабочий лист данных. Обратите внимание, что это начнется в столбце A вашего рабочего листа данных, затем вставьте его в B, C,….

Также не используйте .Activate, поскольку вы уже установили свои рабочие листы на переменные SourceWS и TargetWS вы можете использовать их без активации dircetcy.

Вы можете использовать .Offset(RowOffset:=1) для перехода от найденного заголовка на одну строку вниз, чтобы он начинался со строки 2 только для копирования данных (без заголовка).

Option Explicit

Public Sub CopyColumnsByName()   
    Dim SourceWS As Worksheet
    Set SourceWS = Workbooks("UTTREKK.xlsx").Worksheets(1)

    Dim TargetWS As Worksheet
    Set TargetWS = Workbooks("Target.xlsm").Worksheets("data")

'COPY AND PASTE COLUMNS
    Dim LastRowA As Long  'last row in col A (use for all copy actions)
    LastRowA = SourceWS.Cells(SourceWS.Rows.Count, "A").End(xlUp).Row

    Dim LastCol As Long   'last column for search
    LastCol = SourceWS.Cells(1, SourceWS.Columns.Count).End(xlToLeft).Column

    Dim SearchRange As Range  'define search range for column name
    Set SearchRange = SourceWS.Range("A1", SourceWS.Cells(1, LastCol))

    Dim ColumnNameList() As Variant
    ColumnNameList = Array("id", "sisteprosess", "hendelse")  'your columns list

    Dim PasteColumn As Long
    PasteColumn = 1 'start pasting in column 1 of your data worksheet

    Dim ColumnName As Variant
    For Each ColumnName In ColumnNameList
        With SearchRange
            Dim FoundAt As Range
            Set FoundAt = .Find(What:=ColumnName, _
                            After:=.Cells(1), _
                            LookIn:=xlValues, _
                            LookAt:=xlWhole, _
                            SearchOrder:=xlByRows, _
                            SearchDirection:=xlPrevious, _
                            MatchCase:=False)
            If Not FoundAt Is Nothing Then
                SourceWS.Range(FoundAt.Offset(RowOffset:=1), SourceWS.Cells(LastRowA, FoundAt.Column)).Copy Destination:=TargetWS.Cells(2, PasteColumn)
                PasteColumn = PasteColumn + 1 'move to next paste column
            End If
        End With
    Next ColumnName
End Sub

Обратите внимание, что здесь список столбцов ColumnNameList = Array("id", "sisteprosess", "hendelse") жестко запрограммирован. Если они у вас уже есть в пункте назначения, вы можете лучше прочитать их оттуда, а не записывать в свой код.

ColumnNameList = TargetWS.Range("A1", TargetWS.Cells(1, TargetWS.Columns.Count).End(xlToLeft)).Value