VBA - копировать значения столбцов из нескольких листов на основе заголовков столбцов. - PullRequest
0 голосов
/ 30 ноября 2018

Я все еще новичок в VBA, и я немного растерян, как решить эту конкретную проблему.

У меня есть несколько рабочих листов в одной рабочей книге.Цель состоит в том, чтобы скопировать данные с каждого рабочего листа на основе заголовков столбцов, поскольку не все заголовки столбцов являются одинаковыми для всех листов.

Например:

Мастер-лист содержит 6 заголовков столбцов, которые я хотел бы использовать.

Лист 1 имеет 8 заголовков столбцов, значения для некоторых столбцов в этом поле являются пустыми.

Лист 2 имеет 7 заголовков столбцов.

Лист 3 имеет 10 заголовков столбцов и т. Д.

Моя цель - перейти на каждый лист, сделать так, чтобы он просматривал заголовки каждого столбца и копировал / вставлял данные в мастер-лист, если столбецзаголовки матчей.

Я не знаю, как заставить его искать последнюю строку и копировать весь столбец на основе заголовка.

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

Sub MasterCombine()

Worksheets("Master").Activate

Dim ws As Worksheet
Set TH = Range("A1:F1")

For Each ws In ActiveWorkbook.Worksheets

    If ws.Name <> "Master" And ws.Range("A8").Value <> "" Then
    ws.Select

    Range("A8").Select
    Range(Selection, Selection.End(xlToRight)).Select
    Range(Selection, Selection.End(xlDown)).Select
    Selection.Copy
    Worksheets("Master").Activate



For Each cell In TH

If cell.Value = "Subject" Then

cell.EntireColumn.Copy


End If

Проблема с вышесказанным заключается в том, что он копирует весь диапазон, но не отфильтровывает заголовки столбцов, которые не являютсяв мастер листе.

Буду признателен за любую помощь.

1 Ответ

0 голосов
/ 30 ноября 2018

Это может сработать.Загрузка ваших Master заголовков в массив.Затем цикл по каждому ws - затем цикл по массиву заголовков.

Option Explicit

Sub MasterMine()

Dim Master As Worksheet: Set Master = ThisWorkbook.Sheets("Master")
Dim LR1 As Long, LR2 As Long, LC1 As Long, LC2 As Long
Dim ws As Worksheet, Found As Range, i As Long, Arr

LC1 = Master.Cells(1, Master.Columns.Count).End(xlToLeft).Column
Arr = Master.Range(Master.Cells(1, 1), Master.Cells(1, LC1)).Value

For Each ws In Worksheets
    For i = LBound(Arr) To UBound(Arr)
        LC2 = ws.Cells(1, ws.Columns.Count).End(xlToLeft).Column
        Set Found = ws.Range(ws.Cells(1, 1), ws.Cells(1, LC2)).Find(Arr(i, 1), LookIn:=xlWhole)
            If Not Found Is Nothing Then
                LR1 = Master.Cells(Master.Rows.Count, i).End(xlUp).Offset(1).Row
                LR2 = ws.Cells(ws.Rows.Count, Found.Column).End(xlUp).Row
                ws.Range(ws.Cells(2, Found.Column), ws.Cells(LR2, Found.Column)).Copy
                    Master.Cells(LR1, i).PasteSpecial xlPasteValues
            End If
    Next i
Next ws

End Sub
...