Прокрутите таблицы в рабочей книге и скопируйте информацию в строку 4 (начиная со столбца B)

Question

Мне нужно написать код, который будет перебирать листы в рабочей книге и копировать информацию, которая находится в ячейке A7 на каждом листе. Мне также нужно пропустить дублирование, например, если информация в ячейке A7 одинакова на нескольких листах, мне нужно скопировать ее только один раз в ячейку B4 на листе «Качество данных» и перейти на другой лист, пока не будет найден другой информация, а затем скопировать эту новую информацию в C4 и т. д.

Вот начало кода для запуска цикла:

InputData()

    Dim sh As Worksheet
    Dim DestSh As Worksheet
    Dim Last As Long
    Dim CopyRng As Range

    With Application
        .ScreenUpdating = False
        .EnableEvents = False
        Set DestSh = Sheets("Data Quality")
        For Each sh In ActiveWorkbook.Worksheets
            Select Case sh.Name
                Case DestSh.Name, "Overall Summary", "Confidence Level", "Standard Reporting Rules"
                Case Else

Здесь мне нужно ввести код для копирования информации из ячейки A7 на каждом листе в строку 4, начиная со столбца B, и, если есть дубликаты, для их удаления.

Answer 1

Показывает общие для обоих вариантов из комментария (оба не проверены):

словарь:

dim dc as scripting.dictionary, i as long, ws as worksheet
set dc as new scripting.dictionary
for each ws in worksheets
    dc(ws.cells(7,1).value)=ws.cells(7,1).value 
next
sheets("data quality").cells(4,2).resize(,dc.count+2).value = application.transpose(dc.keys)

матч ():

dim ws as worksheet, lcd as long
for each ws in worksheets
    with sheets("data quality")
        if isempty(.cells(4,2).value) then
            lcd = 2
        else
            lcd = .cells(4,.columns.count).end(xltoleft).columns
        end if
        if not application.match(ws.cells(7,1).value,.range(.cells(4,2),.cells(4,lcd)),0) then .cells(4,lcd+1).value = ws.cells(7,1).value
    end with
next

Answer 2

Другой альтернативный ответ с использованием For Each Loop и CounntIf

Dim ws As Worksheet, c As Long
c = 2

    For Each ws In ThisWorkbook.Worksheets
        If ws.Name <> "Data Quality" Then
            Sheets("Data Quality").Cells(4, c).Value = ws.Cells(7, 1).Value
        c = c + 1
        End If
    Next ws

    With Sheets("Data Quality")
    Dim lCol As Long, cnt As Long
    lCol = Cells(4, Columns.Count).End(xlToLeft).Column

        For x = lCol To 2 Step -1
        cnt = Application.WorksheetFunction.CountIf(Range(Cells(4, 2), Cells(4, x)), Cells(4, x))
            If cnt > 1 Then Cells(4, x).Delete Shift:=xlToLeft
        Next x
    End With