Сравнение диапазонов vba excel - Word и Excel - помощь в работе с программами

If I understand your problem correctly, the following code should allow you to do what you want. Within the code, you select the range you wish to process; the first column of each data set, and the number of columns within each data set.

It does assume only two data sets, as you wrote, although that could be expanded. And there are ways of automatically determining the dataset columns, if there is no other data in between.

Option Explicit
Option Base 0
Sub RemoveDups()
    Dim I As Long, J As Long
    Dim rRng As Range
    Dim vRng As Variant, vRes() As Variant
    Dim bRng() As Boolean
    Dim aColumns, lColumns As Long
    Dim colRowsDelete As Collection

'vRng to include from first to last column to be tested
Set rRng = Range("f1", Cells(Rows.Count, "F").End(xlUp)).Resize(columnsize:=100)
vRng = rRng
ReDim bRng(1 To UBound(vRng))

'columns to be tested
'Specify First column of each data set
aColumns = Array(1, 13)

'num columns in each data set
lColumns = 3

For I = 1 To UBound(vRng)
    bRng(I) = vRng(I, aColumns(0)) = vRng(I, aColumns(1))
    For J = 1 To lColumns - 1
        bRng(I) = bRng(I) And (vRng(I, aColumns(0) + J) = vRng(I, aColumns(1) + J))
    Next J
Next I

'Rows to Delete
Set colRowsDelete = New Collection
For I = 1 To UBound(bRng)
    If bRng(I) = True Then colRowsDelete.Add Item:=I
Next I

'Delete the rows
If colRowsDelete.Count > 0 Then
Application.ScreenUpdating = False
    For I = colRowsDelete.Count To 1 Step -1
        rRng.Rows(colRowsDelete.Item(I)).EntireRow.Delete
    Next I
End If
Application.ScreenUpdating = True
End Sub

Источник

Gorr98

Пользователь

Сообщений: 17
Регистрация: 29.06.2016

Подскажите пожалуйста, как организовать поиск на несовпадение?
На первом листе таблицу надо сравнить с таблицей на втором листе. Если найдены несовпадения, добавить не совпавшее значение в таблицу на первом листе.
В моем коде вроде находится, но не добавляется.

Прикрепленные файлы

П3.xlsm (20.69 КБ)

Юрий М

Модератор

Сообщений: 60588
Регистрация: 14.09.2012

Контакты см. в профиле

29.06.2016 18:50:38

Цитата
Gorr98 написал: В моем коде вроде находится, но не добавляется

Не находится, так как на втором листе нет значений, которые бы отсутствовали на первом.
См. мой вариант. Если значений ОЧЕНЬ много (тысячи строк), то есть смысл делать на массивах.
P.S. Чудной код у Вас )) Сами писали или где-то подсмотрели?

Прикрепленные файлы

П3 01.xlsm (22.26 КБ)

JeyCi

Пользователь

Сообщений: 3357
Регистрация: 27.11.2013

29.06.2016 19:56:42

а что делать с дублями в 1-й таблице?
и можно ли итог отсортировать (особенность запросов — автосортировка по ключевому полю…
если 1-е) нет не нужны и 2-е) да можно…
то SQL-запрос на добавление новых будет выглядеть так (как вариант)… для разнообразия

Код

SELECT t.Номер FROM `Лист1$` t
UNION
SELECT ttt.Номер FROM `Лист2$` ttt
WHERE ttt.Номер NOT IN (
SELECT t.Номер FROM `Лист1$` t
INNER JOIN  `Лист2$` tt
ON t.Номер=tt.Номер)

файл в папку C:1

Прикрепленные файлы

П3.xlsm (21.75 КБ)

Изменено: JeyCi — 29.06.2016 20:20:29

чтобы не гадать на кофейной гуще, кто вам отвечает и после этого не совершать кучу ошибок — обратитесь к собеседнику на ВЫ — ответ на ваш вопрос получите — а остальное вас не касается (п.п.п. на форумах)

Мотя

Пользователь

Сообщений: 3218
Регистрация: 25.12.2012

29.06.2016 20:43:07

Цитата
JeyCi написал: а что делать с дублями в 1-й таблице?

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

Gorr98

!
См. вариант «на массивах», о которых говорил

Юрий М

Прикрепленные файлы

П3-1.xlsm (23.02 КБ)

Gorr98

Пользователь

Сообщений: 17
Регистрация: 29.06.2016

Огого! Никогда бы не подумал, что это может быть так просто, да еще и в такое маленькое количество строк!

Спасибо большое, благодаря таким, как вы, чайники вроде меня черпают опыт чашками, а не ложками)

Насчет кода — да, согласен, очень чудной, может потому, что основу подсмотрел, а потом попытался сам его изменить.

Hugo

Пользователь

Сообщений: 23257
Регистрация: 22.12.2012

30.06.2016 08:32:14

Цитата
Gorr98 написал: да еще и в такое маленькое количество строк!

так показали бы тут код где ещё меньше строк — тот с кибера от fever brain

Код

Sub Сравнение() Dim r1 As Range, r2 As Range, v, w, i& With Sheets(1) Set r1 = .Range(.Cells(1, 1), .Cells(.Cells(.Rows.Count, 1).End(xlUp).Row, 1)) End With With Sheets(2) Set r2 = .Range(.Cells(1, 1), .Cells(.Cells(.Rows.Count, 1).End(xlUp).Row, 1)) End With For Each v In r1 For Each w In r2 If v = w Then GoTo 1 Next i = i + 1: Sheets(1).Cells(i, 3) = v 1 Next MsgBox (Choose(Sgn(i) + 1, "Всё совпало", "Имеются различия смотрите колонку [C]")) End Sub

Только тут у него идёт сравнение обратное заказанному, но не суть.
Да и там есть добавка:

Код
Сравниваем второй лист с первым наоборот: For Each v In r2 For Each w In r1 If v = w Then GoTo 1 Next i = i + 1: Sheets(1).Cells(i, 3) = v 1 Next

Если данных много — добавкой rn=rn.value можно анализ перевести в массивы (только тип rn убрать).

Изменено: Hugo — 30.06.2016 08:33:02

Gorr98

Пользователь

Сообщений: 17
Регистрация: 29.06.2016

30.06.2016 16:59:30

Код

Sub Сравнить_2()
Dim i As Long, LastRow As Long, Rng As Range, FreeRow As Long
    FreeRow = Cells(Rows.Count, 1).End(xlUp).Row + 1
    With Sheets("Лист2")
        LastRow = .Cells(Rows.Count, 1).End(xlUp).Row
        For i = 2 To LastRow
            Set Rng = Columns(1).Find(what:=.Cells(i, 1), LookIn:=xlFormulas, lookAt:=xlWhole)
            If Rng Is Nothing Then
                Cells(FreeRow, 1) = .Cells(i, 1)
                FreeRow = FreeRow + 1
            End If
        Next
    End With
End Sub

Юрий М, расскажите, пожалуйста, что означают приставки xl? Так и не смог разобраться. Знаю, что xlUp — это верхняя граница. Кстати, почему мы используем верхнюю границу, а не нижнюю? С нижней попробовал — не работает. Но ведь мы используем последнее значение снизу — почему тогда xlUp?

Set Rng = Columns(1).Find(what:=.Cells(i, 1), LookIn:=xlFormulas, lookAt:=xlWhole) — а в этой строке такая логика, что задаем Rng первую колонку и ищем ее в первой колонке добавленного листа, верно? Если да, то what тут означает «ищем совпадение»? А что значат LookIn и lookAt?

Надеюсь, что не сильно завалил вопросами :oops:

Hugo

Пользователь

Сообщений: 23257
Регистрация: 22.12.2012

По второму вопросу — задаём не первую колонку, а задаём найти. И ищем в первой колонке что, в чём и как.
И если нашлось, то… далее по коду.

А xlUp — это вверх. Вверх от в данном случае последней ячейки столбца, пока не наткнёмся на значение.
Можно идти и вниз от первой — но обычно ведь бывают пустые ячейки…

Юра, я пришёл — а тебя нет…

Изменено: Hugo — 30.06.2016 17:20:23

Юрий М

Модератор

Сообщений: 60588
Регистрация: 14.09.2012

Контакты см. в профиле

30.06.2016 17:13:02

Всякие xl — это своего рода константы-сокращения: xlFormulas, xlWhole, xlNone, XlYesNo и т.д. Т.е. «готовые к употреблению» параметры )

Цитата
Gorr98 написал: что значат LookIn и lookAt?

what — какое значение ищем.
LookIn — где ищем. Варианты: значения или формулы.
lookAt — точное совпадение или частичное.

Gorr98

Пользователь

Сообщений: 17
Регистрация: 29.06.2016

О! с what, lookIn и lookAt понятно стало, а вот xlUp не совсем — выходит, да, бывают пустые ячейки, на которые xlDown наткнется и подумает, что это конец данных. Но xlUP ведь тоже должен тогда споткнуться об эту же пустую ячейку?
А насчет констант-сокращений — есть какой-то список этих сокращений?

И еще, если возможно, посоветуйте, пожалуйста, какую-нибудь литературу по vba

Hugo

Пользователь

Сообщений: 23257
Регистрация: 22.12.2012

xlUP идёт снизу вверх, по пустым, он наткнётся на первую заполненную. Снизу!
А xlDown пускают свеху вниз по полным, он тормознёт на пустой.
Иногда нужно использовать xlDown — например чтоб пройтись по плотно заполненной таблице, под которой ниже ещё есть данные, после пустых ячеек.

список этих сокращений — в редакторе жмёте F2, там всё.

Изменено: Hugo — 30.06.2016 18:01:31

С.М.

Пользователь

Сообщений: 936
Регистрация: 22.12.2012

#12

30.06.2016 21:36:14

Вариант с xlDown:

Код

Sub Test2()
    Dim Rng1 As Range, Rng2 As Range, Counts(), Arr3(), N As Long, J As Long, K As Long
    Set Rng1 = Лист1.Range("A2")
    Set Rng1 = Range(Rng1, Rng1.End(xlDown))
    Set Rng2 = Лист2.Range("A2")
    Set Rng2 = Range(Rng2, Rng2.End(xlDown))
    Counts = Evaluate("INDEX(COUNTIF(" & Rng1.Address(External:=True) & "," & Rng2.Address(External:=True) & "),0,0)")
    N = Rng2.Rows.Count
    ReDim Arr3(1 To N, 1 To 1)
    For K = 1 To N
        If Counts(K, 1) = 0 Then
            J = J + 1
            Arr3(J, 1) = Rng2.Cells(K, 1)
        End If
    Next
    MsgBox "Найдено несовпадений: " & J, , ""
    Rng1.Cells(Rng1.Rows.Count + 1).Resize(N).Value = Arr3
End Sub

Прикрепленные файлы

Сравнение двух диапазонов на несовпадение.xls (55 КБ)

Источник

2 / 2 / 0

Регистрация: 10.05.2012

Сообщений: 45

Сравнение двух диапазонов ячеек на совпадение

29.05.2012, 00:04. Показов 23546. Ответов 20

Здравствуйте! Подскажите пожалуйста…
Имеется 2 диапазона ячеек А1:A3 и C1:C3, в которых забиты цифры, допустим в ячейках А1:A3 (3,6,2 соответственно), а в C1:C3 (2, 4, и мне необходимо, чтобы при нахождении одинаковых значений выводилось сообщение. Спасибо

~~Апострофф~~

Заблокирован

29.05.2012, 06:59

Visual Basic

Sub cmp()
Dim a As Range, c As Range
For Each a In [A1:A3]
  For Each c In [C1:C3]
    If a = c Then MsgBox a & "=" & c
  Next c
Next a
End Sub

2 / 2 / 0

Регистрация: 10.05.2012

Сообщений: 45

31.05.2012, 13:37

[ТС]

Спасибо, а как сделать чтобы этот же код продолжал работать в след.ячейках например не А1:А3 и С1:С3, а изменил диапазон со сдвигом вправо, т.е. В1:В3 и D1: D3 стало, чтобы не писать его для всех ячеек, а просто со сдвигом вправо? Спасибо

17993 / 7619 / 890

Регистрация: 25.12.2011

Сообщений: 11,352

Записей в блоге: 17

01.06.2012, 09:20

И сколько таких сдвигов планируется?

2 / 2 / 0

Регистрация: 10.05.2012

Сообщений: 45

01.06.2012, 13:00

[ТС]

Примерно 30 сдвигов

Dragokas

17993 / 7619 / 890

Регистрация: 25.12.2011

Сообщений: 11,352

Записей в блоге: 17

01.06.2012, 16:15

Сообщение было отмечено как решение

Решение

1. Прокрутка через смещения
2. Исключено сравнение пустых строк
3. Информация о позиции найденных ячеек

Visual Basic

Sub cmp()
Dim a As Range, c As Range, n As Integer
For n = 0 To 30 'êîë-âî ñìåùåíèé
  For Each a In [A1:A3].Offset(, n)
    For Each c In [C1:C3].Offset(, n)
      If a = c And Len(a) <> 0 Then MsgBox a & "=" & c & " (" & _
        Replace(a.Address & " = " & c.Address & ")", "$", "")
Next c, a, n
End Sub

ikki

призрак

3261 / 889 / 119

Регистрация: 11.05.2012

Сообщений: 1,702

Записей в блоге: 2

01.06.2012, 16:38

Сообщение от Diskretor

Visual Basic

1	Replace(a.Address & " = " & c.Address & ")", "$", "")

а так не проще?

Visual Basic

1	a.Address(0,0) & " = " & c.Address(0,0)

Dragokas

01.06.2012, 17:23

Не по теме:

Да, я забыл как это делается. Спасибо.

2 / 2 / 0

Регистрация: 10.05.2012

Сообщений: 45

01.06.2012, 22:54

[ТС]

Спасибо!

Сообщение от Diskretor

Len(a) <> 0

а что значит эта строка?

17993 / 7619 / 890

Регистрация: 25.12.2011

Сообщений: 11,352

Записей в блоге: 17

02.06.2012, 05:16

Без нее, если попадутся 2 пустые ячейки, начнет писать о совпадении.

У меня они были почти все пустые, поэтому я это дело отключил.

2 / 2 / 0

Регистрация: 10.05.2012

Сообщений: 45

02.06.2012, 08:45

[ТС]

Спасибо! Как раз то, что нужно.

irealife

2 / 2 / 0

Регистрация: 10.05.2012

Сообщений: 45

03.07.2012, 23:15

[ТС]

Visual Basic

Dim a As Range, c As Range, n As Integer
For n = 0 To 150 Step 3 'кол-во смещений
  For Each a In [F3:H3].Offset(, n)
    For Each c In [CC3:CE3].Offset(, n)
      If a = c And Len(a) <> 0 Then letters8 = letters8 + 1
Next c, a, n

Подскажите пожалуйста, а как написать так, чтобы к letters8 прибавлялось 1 при одном совпадении и прибавлялась 2 при больше двух совпадениях.

Dragokas

17993 / 7619 / 890

Регистрация: 25.12.2011

Сообщений: 11,352

Записей в блоге: 17

04.07.2012, 02:51

Если правильно Вас понял, общее кол-во совпадений считаем, как сумму любых совпадений значений в 3 х 3 ячеек в текущем смещении. При этом, если совпадений ровно 2, то ничего не прибавляем.

Visual Basic

Dim a As Range, c As Range, n As Integer, k As Integer
For n = 0 To 150 Step 3 'кол-во смещений
  k = 0
  For Each a In [F3:H3].Offset(, n)
    For Each c In [CC3:CE3].Offset(, n)
      If a = c And Len(a) <> 0 Then k = k + 1
    Next
  Next
  Select Case k
    Case 1
      letters8 = letters8 + 1
    Case Is > 2
      letters8 = letters8 + 2
  End Select
Next

2 / 2 / 0

Регистрация: 10.05.2012

Сообщений: 45

07.07.2012, 13:52

[ТС]

При выполнении данного кода, у меня при 1 совпадении все правильно происходит, а при больше двух к letters8 прибавляется 5 вместо 2.

17993 / 7619 / 890

Регистрация: 25.12.2011

Сообщений: 11,352

Записей в блоге: 17

07.07.2012, 14:09

Так здесь добавляется сразу же, как только найдет совпадения в одном смещении.
А Вам нужно, чтобы после просчета всех 150/3 ?

Тогда строку № 15 переместите между 8 и 9 (а № 3 удалить).

2 / 2 / 0

Регистрация: 10.05.2012

Сообщений: 45

07.07.2012, 15:31

[ТС]

У меня снова не выходит, теперь получается так, что при любом количестве совпадений прибавляется к letters8 значение 2, а должно, чтобы при отсутствии совпадений — не прибавляться ничего, при одном совпадении — прибавляться единица. И проблема по-моему в переменной k. Я в ячейки добавляю все разные значения, а k он мне выводит равное трем, поэтому и прибавляется все время 2 к letters8.

17993 / 7619 / 890

Регистрация: 25.12.2011

Сообщений: 11,352

Записей в блоге: 17

07.07.2012, 22:30

Можете выложить файл с некоторыми фрагментами цифер для теста.

2 / 2 / 0

Регистрация: 10.05.2012

Сообщений: 45

08.07.2012, 01:15

[ТС]

А вы можете почту написать свою? я на почту скину файл?

Добавлено через 2 часа 23 минуты
Diskretor, спасибо! Я поняла в чем ошибка была)

Добавлено через 13 минут
Последний вопрос по теме: имеется массив значений в excel и выполняется огромный код на строку 3. Необходимо сделать так, чтобы этот же код выполнялся на все заполненные последующие строки в excel. В самом коде было использовано свойство Range с конкретным указанием на ячейки в строке.

Dragokas

17993 / 7619 / 890

Регистрация: 25.12.2011

Сообщений: 11,352

Записей в блоге: 17

08.07.2012, 02:03

Да? А я — нет. Можете просветить, чтобы в следующий раз тоже знать как правильно объяснять?

Visual Basic

Dim Rng As Range, c As Range, n%, k%, R%
Dim letters8(3 To 10)
For R = 3 To 10 'номера строк
  For n = 0 To 150 Step 3 'кол-во смещений
    k = 0 'в каждом смещении вправо K подсчитываем отдельно
    For Each Rng In Range("F" & R & ":H" & R).Offset(, n)
      For Each c In Range("CC" & R & ":CE" & R).Offset(, n)
        If Rng = c And Len(Rng) <> 0 Then k = k + 1
      Next
    Next
    Select Case k
      Case 1
        letters8(R) = letters8(R) + 1
      Case Is > 2
        letters8(R) = letters8(R) + 2
    End Select
  Next n
Next R

Из леттерсов тоже сделал массив, так как не знал они теперь отдельно подсчитываются или складываются из всех строк. Если что поубираете массивы (скобки).

irealife

2 / 2 / 0

Регистрация: 10.05.2012

Сообщений: 45

08.07.2012, 10:30

[ТС]

Вы в самом начале правильно мне все написали, ошибка у меня была в диапазоне: было от 0 до 150, а нужно было от 0 до 75, и в кейсах у меня он не понимал что такое Case 1, поэтому я ему указала конкретно на равенство через Case Is. И все, спасибо вам)

Visual Basic

Dim a As Range, c As Range, n As Integer, k As Integer
For n = 0 To 75 Step 3 'кол-во смещений
  For Each a In [F3:H3].Offset(, n)
    For Each c In [CC3:CE3].Offset(, n)
      If a = c And Len(a) <> 0 Then k = k + 1
    Next
  Next
Next
'MsgBox k
  Select Case k
    Case Is = 1
      letters8 = letters8 + 1
    Case Is >= 2
      letters8 = letters8 + 2
  End Select

Источник

I would like to compare 2 cells’ value and see whether they are match or not.
I know how to do it on excel but I dont’ know how to put it vba code.

Input & output:

The value of cell A1 is already in the excel.
Manually enter a value in Cell B1.
click on a button_click sub to see whether the value on 2 cells are the same or not.
Show «Yes» or «No» on cell C1

Excel formula:

=IF(A1=B1,"yes","no")

asked Jan 21, 2015 at 15:55

Give this a try:

Sub CompareCells()
    If [a1] = [b1] Then
        [c1] = "yes"
    Else
        [c1] = "no"
    End If
End Sub

Assign this code to the button.

answered Jan 21, 2015 at 15:58

Gary’s StudentGary’s Student

95.3k9 gold badges58 silver badges98 bronze badges

If (Range("A1").Value = Range("B1").Value) Then
    Range("C1").Value = "Yes"
Else
    Range("C1").Value = "No"
End If

Chrismas007

6,0654 gold badges23 silver badges47 bronze badges

answered Jan 21, 2015 at 16:03

EswinEswin

292 bronze badges

You can use the IIF function in VBA. It is similar to the Excel IF

[c1] = IIf([a1] = [b1], "Yes", "No")

answered Jan 21, 2015 at 16:47

Paul KellyPaul Kelly

9057 silver badges13 bronze badges

Here is an on change Sub (code MUST go in the sheet module). It will only activate if you change a cell in column B.

Private Sub Worksheet_Change(ByVal Target As Range)
    If Target is Nothing Then Exit Sub
    If Target.Cells.Count > 1 Then Exit Sub
    If Target.Column <> 2 Then Exit Sub
    If Cells(Target.Row, 1).Value = Cells(Target.Row, 2).Value Then
        Cells(Target.Row, 3).Value = "Yes"
    Else
        Cells(Target.Row, 3).Value = "No"
    End If
End Sub

For the record, this doesn’t use a button, but it accomplishes your goal of calculating if the two cells are equal any time you manually enter data into cells in Col B.

answered Jan 21, 2015 at 16:08

Chrismas007Chrismas007

6,0654 gold badges23 silver badges47 bronze badges

Sub CompareandHighlight()
    Dim n As Integer
    Dim sh As Worksheets
    Dim r As Range

    n = Worksheets("Indices").Range("E:E").Cells.SpecialCells(xlCellTypeConstants).Count
    Application.ScreenUpdating = False 

    Dim match As Boolean
    Dim valE As Double
    Dim valI As Double
    Dim i As Long, j As Long

    For i = 2 To n
        valE = Worksheets("Indices").Range("E" & i).Value
        valI = Worksheets("Indices").Range("I" & i).Value

        If valE = valI Then

        Else:                           
            Worksheets("Indices").Range("E" & i).Font.Color = RGB(255, 0, 0)
        End If
    Next i

    Application.ScreenUpdating = True
End Sub

barbsan

3,39811 gold badges21 silver badges28 bronze badges

answered Nov 21, 2018 at 9:29

Источник

Сравнение двух диапазонов с подсветкой отличий

w00t

Дата: Вторник, 07.06.2016, 20:42 |
Сообщение № 1

Группа: Проверенные

Ранг: Форумчанин

Сообщений: 131

Репутация:
3
±

Замечаний:
0% ±

Подскажите, пожалуйста, если у кого желание будет. Иногда что-то кропаю (правда долго), а иногда голова не варит, особенно когда понимаешь, что формулами не вариант, а посчитать отличия хочется.

1. [vba]

[/vba] и до последней залитой любым цветом строки (заливка непрерывная) — исходные заполненные данные
2. [vba][/vba] и до последней залитой любым цветом строки (заливка непрерывная) — данные, основанные на вышеуказанном диапазоне с внесенными правками
3. Есть непрерывный столбец D (с D6 и по конец последних данных) — на основании него заливается цветом вся таблица. То есть можно ориентироваться на один столбец D, определяя нижнюю границу двух диапазонов, либо на условие — что два диапазона, старый и новый — имеют непрерывную заливку по последнюю строку.
4. Если в диапазоне пункта 2 имеет отличие от соответствующей ячейки диапазона пункта 1 — то выделить ее каким-нибудь цветом.

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

К сообщению приложен файл:

1606197.xlsm
(12.9 Kb)

Ответить

_Boroda_

Дата: Вторник, 07.06.2016, 20:51 |
Сообщение № 2

Группа: Модераторы

Ранг: Местный житель

Сообщений: 16618

Репутация:
6465
±

Замечаний:
0% ±

2003; 2007; 2010; 2013 RUS

А Условным форматированием?
Формула

В файле сделано на 99 строк
Сейчас еще добавлю с динамическим диапазоном. Пару минут подождите
Хотя не, не нужно здесь динамическими диапазонами, это я торможу. Здесь нужно умную таблицу создать, чтобы УФ само размножалось — файл _2

Скажи мне, кудесник, любимец ба’гов…
Платная помощь:
Boroda_Excel@mail.ru
Яндекс-деньги: 41001632713405 | Webmoney: R289877159277; Z102172301748; E177867141995

Ответить

w00t

Дата: Вторник, 07.06.2016, 21:55 |
Сообщение № 3

Группа: Проверенные

Ранг: Форумчанин

Сообщений: 131

Репутация:
3
±

Замечаний:
0% ±

Да, то, спасибо. Только с умной таблицей немного сложнее, потому что таблица, которая подгружается в эксель — это рекордсет (ADODB) акцесса 500k строк*55 столбиков и с ней потом еще некоторые манипуляции выполняются (знаю — жесть, но так пока годится и вроде даже нормально шевелится). Не вполне желательно его преобразовывать в такую табличку.

Хотя вопрос на самом деле — что быстрее на таком диапазоне будет и что лучше. С одной стороны — умная таблица — хорошо, но на реальную таблицу пока опасаюсь — вполне может что-то другое поломаться. Если руки дойдут когда-либо, попробую может в готовые выложить.

PS: Да, попробовал умную табличку, правда программно ее активировать, что-то вроде

[vba]

Код

Sub TestSmartTable()
ActiveSheet.ListObjects.Add(xlSrcRange, Range(«B5»).CurrentRegion, , xlYes).Name = «Table2»
End Sub

[/vba]

Но, непонятно как ее просто включить, чтобы никакого форматирования небыло вообще. То есть никаких стилей не применилось, никаких итогов, никаких чередований столбцов. И все-таки в моем случае умные таблицы — небольшое зло, как раз именно потому что автозаполнение и прочие фишки, которые нужно избежать.

Сообщение отредактировал w00t — Вторник, 07.06.2016, 22:47

Ответить

w00t

Дата: Вторник, 07.06.2016, 23:04 |
Сообщение № 4

Группа: Проверенные

Ранг: Форумчанин

Сообщений: 131

Репутация:
3
±

Замечаний:
0% ±

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

Ответить

w00t

Дата: Среда, 08.06.2016, 09:02 |
Сообщение № 5

Группа: Проверенные

Ранг: Форумчанин

Сообщений: 131

Репутация:
3
±

Замечаний:
0% ±

Как вариант (потому что с условным форматированием и умной таблицей совсем никак в моем случае)

В модуле

[vba]

Код

Option Explicit

Public Sub CheckRange()
Dim cell    As Range
Dim xRow    As Long
Dim lstRow  As Long
lstRow = WorksheetFunction.Max(6, Range(«B» & Rows.Count).End(xlUp).Row)
For Each cell In Range(«L6:N» & lstRow)
    cell.Interior.Color = RGB(146, 208, 80)
    If Cells(cell.Row, «D») <> «» Then
        Select Case cell.Column
        Case Is = 12    ‘*  L
            If Cells(cell.Row, «L») <> Cells(cell.Row, «E») Then cell.Interior.Color = RGB(255, 102, 204)
        Case Is = 13    ‘*  M
            If Cells(cell.Row, «M») <> Cells(cell.Row, «F») Then cell.Interior.Color = RGB(255, 102, 204)
        Case Is = 14    ‘*  N
            If Cells(cell.Row, «N») <> Cells(cell.Row, «G») Then cell.Interior.Color = RGB(255, 102, 204)
        End Select
    End If
Next cell
End Sub

[/vba]

и в листе

[vba]

Код

Option Explicit

Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Count > 1 Then Exit Sub
CheckRange
End Sub

[/vba]

К сообщению приложен файл:

Test2.xlsm
(21.0 Kb)

Ответить

nilem

Дата: Среда, 08.06.2016, 10:15 |
Сообщение № 6

Группа: Авторы

Ранг: Старожил

Сообщений: 1612

Репутация:
563
±

Замечаний:
0% ±

Excel 2013, 2016

Павел, привет
попробуйте вот так
[vba]

Код

Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Count > 1 Then Exit Sub
If Intersect(Target, Range(«Таблица1[[new Data1]:[new Data4]]»)) Is Nothing Then Exit Sub
Target.Interior.ColorIndex = IIf(Target.Value = Target(1, -6).Value, 43, 7)
End Sub

[/vba]

Яндекс.Деньги 4100159601573

Ответить

_Boroda_

Дата: Среда, 08.06.2016, 11:15 |
Сообщение № 7

Группа: Модераторы

Ранг: Местный житель

Сообщений: 16618

Репутация:
6465
±

Замечаний:
0% ±

2003; 2007; 2010; 2013 RUS

А у меня вот такой вариант.
Красит при изменении любого количества ячеек в диапазонах столбцов EFGLMN строк с 6 по последнюю заполненную в столбце D
[vba]

Код

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim dd_ As Range, d_ As Range
    r1_ = Range(«D» & Rows.Count).End(xlUp).Row
    If r1_ < 6 Then Exit Sub
    Set dd_ = Intersect(Target, Range(«E6:G» & r1_ & «:L6:L» & r1_))
    If Not dd_ Is Nothing Then
        Application.ScreenUpdating = 0
        tsv0_ = RGB(146, 208, 80)
        tsv1_ = RGB(255, 102, 204)
        sm_ = 7
        For Each d_ In dd_
            of_ = sm_ + 2 * sm_ * (d_.Column > 11)
            ofkr_ = -of_ * (of_ > 0)
            d_.Offset(, ofkr_).Interior.Color = tsv0_
            If d_ <> d_.Offset(, of_) Then
                d_.Offset(, ofkr_).Interior.Color = tsv1_
            End If
        Next d_
    End If
End Sub

[/vba]

К сообщению приложен файл:

Test2_3.xlsm
(18.8 Kb)

Ответить

w00t

Дата: Среда, 08.06.2016, 13:16 |
Сообщение № 8

Группа: Проверенные

Ранг: Форумчанин

Сообщений: 131

Репутация:
3
±

Замечаний:
0% ±

Спасибо! Не разобрался с парой фишек только, сорри что достал)

Если в столбцах с 7 по 11 (которые между нужными) что-то поменять — то закрашивается все с 15 столбца, за пределами таблицы.
ковырял, но пока не вышло отключить закраску, если изменения за пределами EFGLMN (5,6,7,12,13,14 столбцов).

По идее так: [vba]

Код

If d_.Column > 7 And d_.Column < 11 Then Exit Sub

[/vba] перед [vba]

Код

ofkr_ = -of_ * (of_ > 0)

[/vba]

И EFG обычно не меняются. Меняются только LMN.

>Если в L набрать отличное от E значение — то все ок. А если изменить в M или N — то не срабатывает
Эту часть пофиксил [vba]

Код

Set dd_ = Intersect(Target, Range(«E6:G» & r1_ & «:L6:N» & r1_))

[/vba]

Сообщение отредактировал w00t — Среда, 08.06.2016, 13:42

Ответить

_Boroda_

Дата: Среда, 08.06.2016, 13:40 |
Сообщение № 9

Группа: Модераторы

Ранг: Местный житель

Сообщений: 16618

Репутация:
6465
±

Замечаний:
0% ±

2003; 2007; 2010; 2013 RUS

Это я неверно dd_ написал. Вот так нужно
[vba]

Код

Set dd_ = Intersect(Target, Range(«E6:G» & r1_ & «,L6:N» & r1_))

[/vba]

К сообщению приложен файл:

Test2_4.xlsm
(21.0 Kb)

Ответить

w00t

Дата: Среда, 08.06.2016, 14:11 |
Сообщение № 10

Группа: Проверенные

Ранг: Форумчанин

Сообщений: 131

Репутация:
3
±

Замечаний:
0% ±

Павел, привет
попробуйте вот так
Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Count > 1 Then Exit Sub
If Intersect(Target, Range(«Таблица1[[new Data1]:[new Data4]]»)) Is Nothing Then Exit Sub
Target.Interior.ColorIndex = IIf(Target.Value = Target(1, -6).Value, 43, 7)
End Sub

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

[vba]

Код

Option Explicit

Sub test()

Dim ListObj As ListObject

        On Error Resume Next
    Set ListObj = ActiveSheet.ListObjects(«MyData»)
    On Error GoTo 0

        If ListObj Is Nothing Then
        Set ListObj = ActiveSheet.ListObjects.Add(xlSrcRange, Range([B5].End(xlDown), [B5].End(xlToRight)), , xlYes)
        ListObj.Name = «MyData»
        ActiveSheet.ListObjects(«MyData»).Range.EntireColumn.ColumnWidth = 8.13
        ActiveSheet.ListObjects(«MyData»).TableStyle = «»
    Else: ActiveSheet.ListObjects(«MyData»).Unlist
    End If

End Sub

[/vba]

[vba]

Код

ActiveSheet.ListObjects(«MyData»).Range.EntireColumn.ColumnWidth = 8.13

[/vba] — это, потому что иначе AutoFit не отключается. Он сразу применяет какой-то стиль.

Ответить

nilem

Дата: Среда, 08.06.2016, 14:22 |
Сообщение № 11

Группа: Авторы

Ранг: Старожил

Сообщений: 1612

Репутация:
563
±

Замечаний:
0% ±

Excel 2013, 2016

может, умная таблица вообще не нужна?
если будет просто диапазон, замените эту строку
[vba]

Код

If Intersect(Target, Range(«Таблица1[[new Data1]:[new Data4]]»)) Is Nothing Then Exit Sub

[/vba]

на вот эту
[vba]

Код

If Intersect(Target, Range(«B5»).CurrentRegion.Columns(11).Resize(, 3)) Is Nothing Then Exit Sub

[/vba]

Яндекс.Деньги 4100159601573

Сообщение отредактировал nilem — Среда, 08.06.2016, 14:23

Ответить

w00t

Дата: Среда, 08.06.2016, 15:24 |
Сообщение № 12

Группа: Проверенные

Ранг: Форумчанин

Сообщений: 131

Репутация:
3
±

Замечаний:
0% ±

Да, довольно коротко получилось. Форумчане меня уже расстреляют, но еще спрошу. Чтобы на каждое изменение на листе проверял и закрашивал эти ячейки?
У меня в сообщении 6 примитивно, но реагирует. Без разницы что поменял, он пробежал по ним.

А здесь нет. Раз ввел и все, выполнилось для конкретной пары ячеек. То есть что ранее было введено и имеет отличие — останется незакрашенным. Я когда удалил формулу условного форматирования — обнаружил это …

Ладно, поковыряю еще, но вдруг..

Ответить

_Boroda_

Дата: Среда, 08.06.2016, 15:28 |
Сообщение № 13

Группа: Модераторы

Ранг: Местный житель

Сообщений: 16618

Репутация:
6465
±

Замечаний:
0% ±

2003; 2007; 2010; 2013 RUS

То есть что ранее было введено и имеет отличие — останется незакрашенным.

Скопируйте весь диапазон (или E:G, или L:N) и вставьте на то же место

Ответить

w00t

Дата: Среда, 08.06.2016, 15:49 |
Сообщение № 14

Группа: Проверенные

Ранг: Форумчанин

Сообщений: 131

Репутация:
3
±

Замечаний:
0% ±

Но это ж жесть. Большой диапазон копировать и вставлять на каждое измененире листа.

Ответить

_Boroda_

Дата: Среда, 08.06.2016, 15:57 |
Сообщение № 15

Группа: Модераторы

Ранг: Местный житель

Сообщений: 16618

Репутация:
6465
±

Замечаний:
0% ±

2003; 2007; 2010; 2013 RUS

Большой диапазон копировать и вставлять на каждое измененире листа

Это Вы сейчас о чем? Вы просили что?

что ранее было введено и имеет отличие — останется незакрашенным

Вам сказали — ОДИН раз нужно скопировать весь диапазон и вставить его на то же место. Перекрасится все то, что было покрашенным неверно. И все. После этого все изменения в файле будут отслеживаться автоматически.

Ответить

w00t

Дата: Среда, 08.06.2016, 16:38 |
Сообщение № 16

Группа: Проверенные

Ранг: Форумчанин

Сообщений: 131

Репутация:
3
±

Замечаний:
0% ±

Мозг сломается… Я то имел в виду про участок кода Николая. Очень короткий уж он просто, симпатично.

А когда понял, что речь про ваш, то сделал так (разово копипаст, флагом).

[vba]

Код

    Public UpDateFlag As Boolean
    Private Sub Worksheet_Change(ByVal Target As Range)
    Dim dd_ As Range, d_ As Range
    ad_ = Selection.Address
    r1_ = Range(«D» & Rows.Count).End(xlUp).Row
    If r1_ < 6 Then Exit Sub
    Set dd_ = Intersect(Target, Range(«E6:G» & r1_ & «:L6:N» & r1_))
    If Not dd_ Is Nothing Then
        Application.ScreenUpdating = 0
        tsv0_ = RGB(146, 208, 80)
        tsv1_ = RGB(255, 102, 204)
        sm_ = 7
        For Each d_ In dd_
            of_ = sm_ + 2 * sm_ * (d_.Column > 11)
            If d_.Column > 7 And d_.Column < 11 Then Exit Sub
            ofkr_ = -of_ * (of_ > 0)
‘            d_.Offset(, ofkr_).Interior.Color = tsv0_
            If d_ <> d_.Offset(, of_) Then
                d_.Offset(, ofkr_).Interior.Color = tsv1_
            End If
        Next d_
    End If
If UpDateFlag = True Then Exit Sub
    Range(«L6:N» & r1_).Copy
    Range(«L6:N» & r1_).PasteSpecial (xlPasteValues)
    Application.CutCopyMode = 0
    Range(ad_).Select
UpDateFlag = True
End Sub

[/vba]

Сообщение отредактировал w00t — Среда, 08.06.2016, 16:43

Ответить

nilem

Дата: Среда, 08.06.2016, 16:49 |
Сообщение № 17

Группа: Авторы

Ранг: Старожил

Сообщений: 1612

Репутация:
563
±

Замечаний:
0% ±

Excel 2013, 2016

А здесь нет. Раз ввел и все, выполнилось для конкретной пары ячеек.

а если вот эдак вот:
[vba]

Код

Private Sub Worksheet_Change(ByVal Target As Range)
If Intersect(Target, Range(«B5»).CurrentRegion.Columns(11).Resize(, 3)) Is Nothing Then Exit Sub
Dim r As Range
For Each r In Target.Cells
    Select Case r.Column
        Case 12, 13, 14    ‘ 12, 13, 14 means columns L, M, N
            r.Interior.ColorIndex = IIf(r.Value = r(1, -6).Value, 43, 7)
    End Select
Next r
End Sub

[/vba]
edited
это код для обычного диапазона. Если все же нужна умная т-ца, попробуйте просто сохранить на листе маленькую умненькую табличку (:)), и при вставке она сама должна «разрастись» по размерам вставляемых данных

Яндекс.Деньги 4100159601573

Сообщение отредактировал nilem — Среда, 08.06.2016, 16:52

Ответить

_Boroda_

Дата: Среда, 08.06.2016, 16:57 |
Сообщение № 18

Группа: Модераторы

Ранг: Местный житель

Сообщений: 16618

Репутация:
6465
±

Замечаний:
0% ±

2003; 2007; 2010; 2013 RUS

сделал так (разово копипаст, флагом)

Я Вам говорил про ручное единоразовое копирование-вставку. А Вы зачем-то суете все это в макрос.
Я не понимаю что Вы хотите. Вы зачем-то придумываете какие-то извращения непонятные, не объясняя при это, что же Вы хотите получить. И потом говорите, что у Вас не работает. Конечно не работает — код неверный. Извините, но мне надоело.
Ладно, заключительный раз.
Уберите свою переменную и повесьте кусок копи-пасте в событие открытия книги
[vba]

Код

Private Sub Workbook_Open()
    With Worksheet____1
        r1_ = .Range(«D» & Rows.Count).End(xlUp).Row
        .Range(«L6:N» & r1_).Copy .Range(«L6:N» & r1_)
    End With
End Sub

[/vba]

К сообщению приложен файл:

Test2_7.xlsm
(18.5 Kb)

Ответить

Источник