Поиск значения в одном и копирование в другой файл

@blackeangel · Регистрация: 22.07.2015

Студворк — интернет-сервис помощи студентам

Всем добрый день.
Есть такая задачка:
Есть 2 файла:
- в первом > 255 полей и > 800000 строк
- во втором (активном) ококло 1000 строк и около 30 столбцов
Надо написать макрос, который бы брал значение ячейки 2 столбца из первого файла
и сравнивал бы его с значеинем(по входимости(использовать Like)) ячейки столбца найденого по названию столбца во втором файле
если совпало то копируем значение во второй файл в столбец i+1 в текущую строку(где i это столбец найденый по названию столбца)
ACCESS и другие программы не предлагать, т.к. ради ухода от них и спрашивается.
Exel и только Exel.
Пускай долго, но так надо

Добавлено через 5 минут
Сделать это надо не открывая(визуально) первого файла.И закрыть не забыть

@blackeangel · 18.12.2015, 15:16 **[ТС]**

SoftIce, и ещё, в твоём коде не надо переносить на новый лист это раз,второе,если не совпадают то они пропускаются из массива,а они должны остаться.
Сейчас пример ещё один скину.

SoftIce · 18.12.2015, 15:16

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

кто такие m,n? Где они задаются?

Вы код смотрели?

@blackeangel · 18.12.2015, 15:17 **[ТС]**

SoftIce, вот это и надо чтоб остались старые

SoftIce · 18.12.2015, 15:17

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

если не совпадают то они пропускаются из массива,а они должны остаться.

А вот это хорошо как раз, тогда можно и без третьего массива

@blackeangel · 18.12.2015, 15:18 **[ТС]**

SoftIce, смотрел,и его и ваш и ни в одном коде нет упоминания m,n

SoftIce · 18.12.2015, 15:20

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

и ни в одном коде нет упоминания m,n

А откуда же он тогда их взял?

Из моего последнего архива

@blackeangel · 18.12.2015, 15:27 **[ТС]**

Вот

@blackeangel · 18.12.2015, 17:04 **[ТС]**

M,n ,нашёл в последнем архиве...теперь понятно что это за звери.

Добавлено через 47 минут
Кстати,программа не закрывает файл 1 после работы,а надо бы, а то оперативная не резиновая... По крайней мере в коде этого не увидел..

Добавлено через 3 минуты
А если файл 1 уже открыт,то будет задаваться вопрос на повторное открытие?

@blackeangel · 21.12.2015, 13:37 **[ТС]**

Не работает:

Visual Basic
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
Attribute VB_Name = "Module1"
Sub main()
    Dim Arr1, Arr2, Arr3(), S As String
    Dim n As Long, m As Long, i As Long, j As Long
    S = "N:\_7_Все_карточки\Карточки.xlsm"
    If Dir(S) = "" Then 
    MsgBox "???? " & S & " ?? ??????.": Exit Sub
    n = GetObject(S).Worksheets(1).Cells(Rows.Count, "B").End(xlUp).Row
    m = ThisWorkbook.Worksheets(1).Cells(Rows.Count, "B").End(xlUp).Row
   Arr1 = GetObject(S).Worksheets(1).Range("B3", "C" & n).Value
Arr2 = ThisWorkbook.Worksheets(1).Range("B2", "B" & m).Value
For i = 1 To UBound(Arr1, 1)
For j = 1 To UBound(Arr2, 1)
If Arr2(j, 1) Like Arr1(i, 1) & "*" Then
Arr1(i, 2) = Arr2(j, 1)
End If
Next j
Next i
    TranspMatrix Arr3
    ThisWorkbook.Sheets(2).Range(ThisWorkbook.Sheets(2).Cells(2, 2), ThisWorkbook.Sheets(2).Cells(k + 1, 3)) = Arr3
    MsgBox "OK"
End Sub
Private Sub TranspMatrix(ByRef A())
    Dim i As Long, j As Long
    ReDim B(1 To UBound(A, 2), 1 To UBound(A, 1))
    For i = 1 To UBound(A, 1)
       For j = 1 To UBound(A, 2)
           B(j, i) = A(i, j)
       Next j
    Next i
    A = B
End Sub

Ругается 9 ошибкой на

Visual Basic
1
ReDim B(1 To UBound(A, 2), 1 To UBound(A, 1))

В чем печаль?

Добавлено через 12 минут
Вот ссылка на реальные данные
https://yadi.sk/d/XwcVlhnhmN3Ev
Помогите пожалуйста добиться положительного результата...

Добавлено через 14 минут
А если делаю так то на 1004 ошибка

Visual Basic
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
Sub main()
    Dim Arr1, Arr2, Arr3(), S As String
    Dim n As Long, m As Long, i As Long, j As Long
  '  Set Cdlg = CreateObject("MSComDlg.CommonDialog")
   ' Cdlg.CancelError = True: Cdlg.DialogTitle = "Cохранение"
   ' Cdlg.Filter = "‘айлы Excel|*.xlsx"
   ' On Error Resume Next
   ' Cdlg.Showopen
   ' S = Cdlg.Filename
   ' If CStr(S) = "" Then Exit Sub
    S = "N:\_7_Все_карточки\Карточки.xlsm"
   ' If Dir(S) = "" Then MsgBox "‘айл " & S & " не найден.": Exit Sub
sWhatFind = "Обозначение"
Cells.Find(What:=sWhatFind2, After:=ActiveCell, SearchOrder:=xlByColumns).Activate
ncolumn = ActiveCell.Column
    n = GetObject(S).Worksheets(1).Cells(Rows.Count, "B").End(xlUp).Row
    m = ThisWorkbook.Worksheets(1).Cells(Rows.Count, "B").End(xlUp).Row
   Arr1 = GetObject(S).Worksheets(1).Range("B3", "C" & n).Value
Arr2 = ThisWorkbook.Worksheets(1).Range(ncolumn, "B" & m).Value
For i = 1 To UBound(Arr1, 1)
For j = 1 To UBound(Arr2, 1)
If Arr2(j, 1) Like Arr1(i, 1) & "*" Then
Arr1(i, 2) = Arr2(j, 1)
End If
Next j
Next i
    TranspMatrix Arr3
    ThisWorkbook.Sheets(2).Range(ThisWorkbook.Sheets(2).Cells(2, 2), ThisWorkbook.Sheets(2).Cells(k + 1, 3)) = Arr3
'S.Close
    MsgBox "OK"
End Sub
Private Sub TranspMatrix(ByRef A())
    Dim i As Long, j As Long
    ReDim B(1 To UBound(A, 2), 1 To UBound(A, 1))
    For i = 1 To UBound(A, 1)
       For j = 1 To UBound(A, 2)
           B(j, i) = A(i, j)
       Next j
    Next i
    A = B
End Sub

На

Visual Basic
1
Arr2 = ThisWorkbook.Worksheets(1).Range(ncolumn, "B" & m).Value

Добавлено через 5 часов 27 минут
SoftIce, вообще соображений нет как сделать правильно?
А то ваш код выбирает то что есть,а тех которых нет,удаляет,а это ежегодное дело

@Alex77755 · 21.12.2015, 14:07

так пробуй

Visual Basic
1
2
Arr1 = GetObject(S).Worksheets(1).Range("B3:C" & n).Value
Arr2 = ThisWorkbook.Worksheets(1).Range("B3:B" & m).Value

Добавлено через 1 минуту

Visual Basic
1
  TranspMatrix Arr3

Это в последнем варианте уже не нужно: поиск ведётся в самой процедуре

Добавлено через 5 минут
Arr3 теперь не нужен. Всё делается в Arr1.
Поэтому и на лист надо возвращить Arr1

Visual Basic
1
ThisWorkbook.Sheets(2).Range(ThisWorkbook.Sheets(2).Cells(2, 2), ThisWorkbook.Sheets(2).Cells(n, 3)) = Arr1

Добавлено через 6 минут

Кстати,программа не закрывает файл 1 после работы

Для этого можно разбить строчку считывания в массив на 2 строчки:

Visual Basic
1
2
3
Dim wb
Set wb = GetObject(S)
Arr1 = wb.Worksheets(1).Range("B3:C" & n).Value

И в конце процедуры закрыть книгу

Visual Basic
1
wb.Close

@blackeangel · 21.12.2015, 14:28 **[ТС]**

Alex77755,
Сделал вот так

Visual Basic
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
Sub main()
    Dim Arr1, Arr2, Arr3(), S As String
    Dim n As Long, m As Long, i As Long, j As Long
    S = "N:\_7_Все_карточки\Карточки.xlsm"
sWhatFind = "Обозначение"
Cells.Find(What:=sWhatFind2, After:=ActiveCell, SearchOrder:=xlByColumns).Activate
ncolumn = ActiveCell.Column
    n = GetObject(S).Worksheets(1).Cells(Rows.Count, "B").End(xlUp).Row
    m = ThisWorkbook.Worksheets(1).Cells(Rows.Count, "B").End(xlUp).Row
   Arr1 = GetObject(S).Worksheets(1).Range("B3:C" & n).Value
Arr2 = ThisWorkbook.Worksheets(1).Range("B3:B" & m).Value
For i = 1 To UBound(Arr1, 1)
For j = 1 To UBound(Arr2, 1)
If Arr2(j, 1) Like Arr1(i, 1) & "*" Then
Arr1(i, 2) = Arr2(j, 1)
End If
Next j
Next i
    ThisWorkbook.Sheets(2).Range(ThisWorkbook.Sheets(2).Cells(2, 2), ThisWorkbook.Sheets(2).Cells(n, 3)) = Arr1
GetObject(S).Close SaveChanges:=False 'закрываем файл без сохранения
    MsgBox "OK"
End Sub

На выходе получил полностью скопированы данные из файла 1 что не надо делать

Добавлено через 6 минут
Alex77755,
Вы ещё говорили что можно как то через Find LookAt:=xlWhole ?
Может через него будет проще?

Добавлено через 8 минут
Да и ещё по идеи он(макрос) должен вставлять справа от обозначения столбец и в него записывать,поэтому ч и пытаюсь через поиск столбца это реализовать...никто не знает в каком будет столбце "обозначение"... Но вы посему то решили обе колонки заменить...

@Alex77755 · 21.12.2015, 14:30

согласуй имена массивов с книгами: какой массив находится в активной книге (файле 2), какой в файле 1
Неужели трудно согласовать? Ведь весь принцип расписан!

@blackeangel · 21.12.2015, 14:56 **[ТС]**

Alex77755, нет,через матрицу мы с вами эту задачу не решим...так как должно присутствовать пустые записи,которые матрица не поддерживает...будем решать через find...
Да,что согласовывать если все согласовано и ещё один важный момент,ну не понимаю я как это через матрицу можно сделать...через fir,if и тп операторы могу понять,но с матрицей или массивом нет,ну не укладывается у меня в голове...
Вариант SoftIce через 3й массив был нормальный за исключением того что он удалял те что не совпали

Добавлено через 8 минут
Я бы конечно решал задачу по другому если бы не было этих вот "-хх"тогда бы простым поиском по файлу и всё...или же можно как то их оторвать и поискать?

А через вот это

Visual Basic
1
2
3
4
On Error Resume Next
Dim x As Range
   Set x = Cells.Find(What:="", LookIn:=xlValues, LookAt:=xlWhole, SearchOrder:=xlByRows)
    x.Activate

Как реализовать и стоит ли?

@Alex77755 · 21.12.2015, 15:02

никто не знает в каком будет столбце "обозначение"

Адресацию массивов подпили под свои нужды

которые матрица не поддерживает..

А вот с этого места поподробнее!
Я, видимо, чего-то не знаю\

Добавлено через 2 минуты
И упорно не хотите использовать Option Explicit
назначается одна переменная, а ищется другая
И обе не объявлены

Visual Basic
1
2
sWhatFind = "Обозначение"
Cells.Find(What:=sWhatFind2,

@blackeangel · 21.12.2015, 15:16 **[ТС]**

Alex77755,

назначается одна переменная, а ищется другая
И обе не объявлены

Это не суть кстати, пробовал по всякому
На выходе получаю 1004 ошибку в строке

Visual Basic
1
Аrr2 = ThisWorkbook.Worksheets(1).Range(х & m).Value

при

Visual Basic
1
2
3
Dim x As Range
   Set x = Cells.Find(What:="обозначение", LookIn:=xlValues, LookAt:=xlWhole, SearchOrder:=xlByRows)
    x.Activate

@Alex77755 · 21.12.2015, 15:22

Visual Basic
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
Sub main()
Dim sWhatFind, ncolumn, rn As Range
 
    Dim Arr1, Arr2, Arr3(), S As String
    Dim n As Long, m As Long, i As Long, j As Long
    Dim wb
    
'range и массив рабочей книги
sWhatFind = "Обозначение"
ncolumn = Cells.Find(What:=sWhatFind, After:=ActiveCell, SearchOrder:=xlByColumns).Column
m = ThisWorkbook.Worksheets(1).Cells(Rows.Count, ncolumn).End(xlUp).Row
Set rn = ThisWorkbook.Worksheets(1).Cells(3, ncolumn).Resize(m, 2)
Arr2 = rn.Value
 
'массив первой книги
'    S = "N:\_7_Все_карточки\Карточки.xlsm"
    S = ActiveWorkbook.Path & "\Файл 1.xlsx"
    Set wb = GetObject(S)
    n = wb.Worksheets(1).Cells(Rows.Count, "B").End(xlUp).Row
    Arr1 = wb.Worksheets(1).Range("B3:C" & n).Value
    wb.Close 'закрываем файл без сохранения
    
    For i = 1 To UBound(Arr1, 1)
        For j = 1 To UBound(Arr2, 1)
            If InStr(1, Arr2(j, 1), Arr1(i, 1)) > 0 Then
'            Debug.Print Arr2(j, 1), Arr1(i, 1)
                Arr2(j, 2) = Arr1(i, 1)
                Exit For
            End If
        Next j
    Next i
   rn = Arr2
 
    MsgBox "OK"
 
End Sub

@blackeangel · 21.12.2015, 15:46 **[ТС]**

Alex77755,
Есть 2недостатка в этом коде:
1) файл спрашивает сохранение -решил сам
2) если есть "-хх" то не выполняе своей задачи. если из массива 1 и массива 2 точно совпадает то записывается, а если нет,то пропускается...
Как сделать чтоб была входимость?

@Alex77755 · 21.12.2015, 16:05

поменяй местами
Arr2(j, 1), Arr1(i, 1)
в строке поиска

Visual Basic
1
 If InStr(1, Arr2(j, 1), Arr1(i, 1)) > 0 Then

Добавлено через 3 минуты
If InStr(с какой позиции искать, где искать, что искать) > 0 Then
Вро де же писал искать вхождение первого массива во втором?

@blackeangel · 21.12.2015, 16:12 **[ТС]**

Alex77755, именно из первого(того большого) и все вхождения,а не первые...
Смена местами проблему не решила.
Вот смотрите:
если есть жг.8.700.600
То к жг.8.700.600-01 напротив надо поставить жг.8.700.600
Макрос этого не делает,он только напротив жг.8.700.600 ставит жг.8.700.600, а напротив жг.8.700.600-01 пусто.

@Alex77755 · 21.12.2015, 16:37

Да. Я сделал поиск до первого и потом выход из цикла. что-то не подумал о возможных повторенияж.
В первом варианте удалить строчку Exit For

Новые блоги и статьи Все статьи Все блоги /
ИИ не может найти нужный язык в списке Supersumestria 05.10.2026 Я ему даю вот такое изображение и прошу найти и подчеркнуть немецкий язык. Возвращает он вот это: https:/ / i. **********/ vqBWLe2. png Нужную строчку в 3й колонке просто выдумал. . Это. . .	Новая последняя моя музыка в SUNO zorxor 05.10.2026 Здравствуйте, дорогие мои друзья! С большой радостью я хотел бы представить вам свою новую последнею музыку, которую сгенерировала мне по моей просьбе нейросеть SUNO. С уважением, zorxor. Это. . .	Программный домашний кинотеатр russiannick 27.09.2026 Сподобился на программный домашний кинотеатр. В качестве ЯВУ по традиции выбрал js. В помощники взял Яндекс-Алису. Было создано три зала на разные интересы. исторические и ретро сериал Хичкок. . .	Беседа с ИИ о программистах, недопускающих к созданию и правке кода генеративные ИИ и причины этого zorxor 21.09.2026 Раньше я радовался или получал некоторые эмоции, пусть небольшие, но всё же, от самого процесса написания кода, рекомпиляции и запуска, видя постепенное развитие программы и прочее. А теперь лень. . .
Мобильное приложение ColorStep pavlinmavlin 17.09.2026 Реализовал приложение Красный, Зеленый, Синий в Unity3d + c#. Название изменил на ColorStep. Приложение прошло модерацию и теперь доступно для скачивания. Делал его сам, шаг за шагом — и вот,. . .	Запрет дублирования строк в табличной части Maks 13.09.2026 Реализация из решения ниже выполнена на нетиповом справочнике "Нормы ТО" с табличной часть "Виды ТО", разработанного в КА2, со следующими реквизитами: - ВидТО (СправочникСсылка. ВидыТО); - ВидГСМ. . .	Скрипты Tampermonkey для CyberForum, ChatGPT, Claude и пр. Jin X 06.09.2026 Скрипты Tampermonkey для CyberForum, ChatGPT, Claude и пр. Работая с форумом и нейросетями в браузере часто хочется что-то подкорректировать или добавить какого-то функционала. Ниже прикреплён. . .	Программа опроса у.з. расходомера SLS-720F Argus19 02.09.2026 Программа опроса у. з. расходомера SLS-720F Программа опрашивает один раз в минуту три ультразвуковых расходомера SLS-720F через интерфейс RS-485 по протоколу Modbus RTU. Опрашиваются регистры. . .

@blackeangel 19 / 10 / 1 Регистрация: 22.07.2015 Сообщений: 908

	Поиск значения в одном и копирование в другой файл 18.12.2015, 10:45. Показов 9192. Ответов 81 Метки нет (Все метки) Всем добрый день. Есть такая задачка: Есть 2 файла: - в первом > 255 полей и > 800000 строк - во втором (активном) ококло 1000 строк и около 30 столбцов Надо написать макрос, который бы брал значение ячейки 2 столбца из первого файла и сравнивал бы его с значеинем(по входимости(использовать Like)) ячейки столбца найденого по названию столбца во втором файле если совпало то копируем значение во второй файл в столбец i+1 в текущую строку(где i это столбец найденый по названию столбца) ACCESS и другие программы не предлагать, т.к. ради ухода от них и спрашивается. Exel и только Exel. Пускай долго, но так надо Добавлено через 5 минут Сделать это надо не открывая(визуально) первого файла.И закрыть не забыть 0

@blackeangel 19 / 10 / 1 Регистрация: 22.07.2015 Сообщений: 908
	18.12.2015, 15:16 [ТС]
	SoftIce, и ещё, в твоём коде не надо переносить на новый лист это раз,второе,если не совпадают то они пропускаются из массива,а они должны остаться. Сейчас пример ещё один скину. 0

@blackeangel 19 / 10 / 1 Регистрация: 22.07.2015 Сообщений: 908
	18.12.2015, 15:17 [ТС]
	SoftIce, вот это и надо чтоб остались старые 0

@blackeangel 19 / 10 / 1 Регистрация: 22.07.2015 Сообщений: 908
	18.12.2015, 15:18 [ТС]
	SoftIce, смотрел,и его и ваш и ни в одном коде нет упоминания m,n 0

@blackeangel 19 / 10 / 1 Регистрация: 22.07.2015 Сообщений: 908
	18.12.2015, 17:04 [ТС]
	M,n ,нашёл в последнем архиве...теперь понятно что это за звери. Добавлено через 47 минут Кстати,программа не закрывает файл 1 после работы,а надо бы, а то оперативная не резиновая... По крайней мере в коде этого не увидел.. Добавлено через 3 минуты А если файл 1 уже открыт,то будет задаваться вопрос на повторное открытие? 0

@Alex77755 11525 / 3812 / 683 Регистрация: 13.02.2009 Сообщений: 11,229
	21.12.2015, 14:30
	согласуй имена массивов с книгами: какой массив находится в активной книге (файле 2), какой в файле 1 Неужели трудно согласовать? Ведь весь принцип расписан! 0

@blackeangel 19 / 10 / 1 Регистрация: 22.07.2015 Сообщений: 908
	21.12.2015, 15:46 [ТС]
	Alex77755, Есть 2недостатка в этом коде: 1) файл спрашивает сохранение -решил сам 2) если есть "-хх" то не выполняе своей задачи. если из массива 1 и массива 2 точно совпадает то записывается, а если нет,то пропускается... Как сделать чтоб была входимость? 0

@blackeangel 19 / 10 / 1 Регистрация: 22.07.2015 Сообщений: 908
	21.12.2015, 16:12 [ТС]
	Alex77755, именно из первого(того большого) и все вхождения,а не первые... Смена местами проблему не решила. Вот смотрите: если есть жг.8.700.600 То к жг.8.700.600-01 напротив надо поставить жг.8.700.600 Макрос этого не делает,он только напротив жг.8.700.600 ставит жг.8.700.600, а напротив жг.8.700.600-01 пусто. 0

@Alex77755 11525 / 3812 / 683 Регистрация: 13.02.2009 Сообщений: 11,229
	21.12.2015, 16:37
	Да. Я сделал поиск до первого и потом выход из цикла. что-то не подумал о возможных повторенияж. В первом варианте удалить строчку Exit For 0