Sub aaaaaaaabbb()
Dim arr()
Dim i As Long
Dim q As Variant
Dim matchFound As Boolean
Dim numColumns As Long
lLastRowA = Sheets("A").Cells(Rows.Count, 1).End(xlUp).Row
lLastRowB = Sheets("B").Cells(Rows.Count, 1).End(xlUp).Row
Set rngA = Sheets("A").Range("A2:C" & lLastRowA)
Set rngB = Sheets("B").Range("A2:C" & lLastRowB)
numColumns = rngA.Columns.Count
ReDim arr(1 To lLastRowA, 1 To numColumns)
For rA = 1 To rngA.Rows.Count
matchFound = False
For rB = 1 To rngB.Rows.Count
If rngA(rA, 1) = q Then
Exit For
End If
If rngA(rA, 1) = rngB(rB, 1) Then
If rngA(rA, 3) - rngB(rB, 2) > 0 Then
q = rngA(rA, 1)
Exit For
End If
matchFound = True
Exit For
End If
Next rB
If Not matchFound Then
i = i + 1
For j = 1 To numColumns
arr(i, j) = rngA(rA, j)
Next j
End If
Next rA
Sheets("A").Range("A2:C" & lLastRowA).ClearContents
Sheets("A").Range("A2").Resize(i, 3).Value = arr
End Sub
delph3r написал: листа "Последняя таблица" со всеми предыдущими листами?
активного листа, со всеми другими
Цитата
delph3r написал: А сильно сложнее будет, если Результат будет выдаваться только тогда, когда все строки колонки B из листа "Последняя таблица" совпадают со всеми строками колонки
delph3r, чтобы сравнить каждый лист с каждым и вывести совпадения:
Код
Код
Sub СравнитьЛисты()
Dim ws As Worksheet
Dim lastRow As Long
Dim i As Long, j As Long, k As Long
Dim wsCompare As Worksheet
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
For Each ws In ActiveWorkbook.Worksheets
lastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row
rng = ws.Range("A2:C" & lastRow)
For r = 2 To UBound(rng)
For Each wsCompare In ActiveWorkbook.Worksheets
If wsCompare.Name <> ws.Name Then
lastRow = wsCompare.Cells(ws.Rows.Count, "A").End(xlUp).Row
rngCompare = wsCompare.Range("A2:C" & lastRow)
For rCompare = 2 To UBound(rngCompare)
If rng(r, 1) & rng(r, 2) & rng(r, 3) = rngCompare(rCompare, 1) & rngCompare(rCompare, 2) & rngCompare(rCompare, 3) Then
found = found & " " & wsCompare.Name
End If
Next
End If
Next wsCompare
ws.Cells(r + 1, 4).value = found
found = ""
Next r
Next ws
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
End Sub
для последнего листа с подсветкой:
Код
Код
Sub СравнитьЛисты()
Dim ws As Worksheet
Dim lastRow As Long
Dim i As Long, j As Long, k As Long
Dim wsCompare As Worksheet
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Set ws = ActiveSheet
lastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row
Rng = ws.Range("A2:C" & lastRow)
For r = 2 To UBound(Rng)
For Each wsCompare In ActiveWorkbook.Worksheets
If wsCompare.Name <> ws.Name Then
lastRow = wsCompare.Cells(ws.Rows.Count, "A").End(xlUp).Row
rngCompare = wsCompare.Range("A2:C" & lastRow)
For rCompare = 2 To UBound(rngCompare)
If Rng(r, 1) & Rng(r, 2) & Rng(r, 3) = rngCompare(rCompare, 1) & rngCompare(rCompare, 2) & rngCompare(rCompare, 3) Then
wsCompare.Range("A" & r + 1 & ":C" & r + 1).Interior.Color = RGB(146, 208, 80)
found = found & " " & wsCompare.Name
End If
Next
End If
Next wsCompare
If found <> "" Then
ws.Cells(r + 1, 4).Value = found
ws.Range("A" & r + 1 & ":C" & r + 1).Interior.Color = RGB(146, 208, 80)
End If
found = ""
Next r
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
End Sub
на всякий случай, я без претензий к кому-либо из модераторов и участников
Цитата
Sanja написал: Мне кажется, постоянно забывается основной принцип данного ресурса - ПОМОЩЬ,
абсолютно с Вами согласен, и я предлагаю в первых трех темах помочь новому участнику научиться соблюдать правила форума, предложив за него название темы, возможно, предложив решение, но указав, что оно пальцем в небо, т.к. нет примера что нужно и т.д.
Jack Famous написал: покажите, пожалуйста, канал в телеге
я бы не сказал, что более популярный но все же, например, Excel Chat.
Цитата
Jack Famous написал: И скажите, как вы определили, что он более популярный?
В основном по количеству сообщения, как бы тупо не звучало
Цитата
Jack Famous написал: Лично для меня, ЛЮБОЙ канал будет проигрывать сайту — чисто из-за формата. Одно дело, новости читать и совсем другое — копаться в темах, кодах и примерах файлов.
абсолютно согласен, хотя есть примеры совсем чуть-чуть похожие на форум, например NSP Chat - ChatGPT. Смысл канала совсем в другом, но тоже создаются топики и в них что-то решается, их можно закрыть, изменить статус
P.S. Я считаю данный форум лучшим по Excel и всего, что с ним связано и именно поэтому создал данную тему
БМВ написал: Кто счет будет вести отведенных трех поедупреждений?
я бы предложил использовать не предупреждения, а количество созданных тем (думаю, что это не сложно отслеживать), но может быть можно использовать эту функцию (я первый раз ее сегодня заметил)?
Цитата
БМВ написал: А помогающих, которые лезут тоже не трогать?
с них как и раньше: помог - предлагай тему
Цитата
БМВ написал: Пока правило есть - оно должно соблюдаться если не описано законное послабление
ну я бы в идеале и хотел, чтобы это стало законным
Цитата
БМВ написал: Надеюсь что никто не считает, что закрывая очередную тему-вопль помогите, нам в радость?
Вы действуете в рамках правил, это логично, поэтому я не в коем случае не хотел никого обидеть.
Всем привет! Наверняка что-то подобное уже поднималось, но все же. Мое предложение - не драконить новых участников форума за плохое название темы или описание, отсутствие файла примера и т.д. хотя бы для первых 3 тем. В большей части, это касается модераторов, но и других участников тоже. Мне кажется, это поможет слегка популяризировать форум, т.к. после закрытия первых двух тем, не очень хочется даже пытаться создавать новую.
Evgenyy, "Если желаешь, чтобы мир изменился, — сам стань этим изменением." Но в целом, я думаю, что БМВ прав, в текущей ситуации все от Microsoft под большим вопросом. По крайней мере в РФ.