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

ProgramBox

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

Post author:admin
Запись опубликована:25 апреля, 2023
Post category:Вопросы по программированию

#excel #vba

Вопрос:

Мне нужно написать код, который будет перебирать листы в книге и копировать информацию, которая находится в ячейке 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, и, если есть какие-либо дубликаты, удалить их.

1. Используйте scripting.dictionary для сбора уникальных ячеек, затем, после того как вы обработали все листы и у вас есть словарь с набором уникальных значений, запишите значения в нужную строку.

2. Freeflow нашел важный ответ… это, вероятно, самый эффективный способ. если вы не пойдете по этому пути, вам понадобится оператор if для match() вашего текущего значения, и если он не найден, динамически найдите последний столбец и вставьте его в последний столбец 1…

Ответ №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

1. Спасибо за вашу помощь, но я получаю сообщение об ошибке для lcd = .Cells (4, .Columns. Количество).Конец (xlToLeft). Столбцы

2. @InnaG что это за сообщение об ошибке? если в строке нет данных, вам нужно будет создать логику для этого

3. В каждой ячейке A7 на всех листах файла указано название продукта. Мне нужно скопировать все имена в строке 4, начиная со столбца B, но без дублирования, например, если на одном листе в ячейке A7 есть «hammer» — я хочу, чтобы это скопировалось на листе «Качество данных», если на следующем листе есть тот же продукт — его нужно пропустить и перейти к следующему листу и так далее. Надеюсь, это имеет смысл.

4. @InnaG Каждый пример будет перебирать листы в книге, ссылаясь на ячейку A7, cells(7,1) Для примера словаря значение добавляется в качестве ключа… может существовать только 1 ключ, поэтому это автоматически удаляет дубликаты; после заполнения словаря is вставляет все ключи, начиная с B4, для улучшения качества данных. В примере с match() проверяется, что в текущей таблице качества данных нет соответствия, и, если нет, добавляется значение к последнему столбцу 1. Оба должны выполнять то, что вы просите, хотя вам может потребоваться добавить немного больше логики, чтобы адаптировать ее к вашим конкретным потребностям.

5. @InnaG обновил код, чтобы отразить снижение качества данных в ячейке B2 в Match() сценарии.

Ответ №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

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

2. @InnaG обновлено, этот код работает, я неправильно прочитал ваше описание и использовал «C4» в качестве начальной ячейки вместо ячейки «B4». После того, как все значения скопированы на лист «Качество данных», дубликаты удаляются, предоставляя диапазон уникальных значений в строке 4, начиная с ячейки «B4»