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

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

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

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

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

@Alex77755 · 09.02.2016, 14:32

И коде нет такого!!!
Есть

Visual Basic
1
 Dim slm: Set slm = CreateObject("Scripting.Dictionary")

И ещё надо строчку добавить

Visual Basic
1
2
        If Len(s) > 0 Then
         s = ActiveWorkbook.Path & "" & s''' ДОБАВИТЬ

Добавлено через 40 секунд
Между "" слеш

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

Visual Basic
1
  s = ActiveWorkbook.Path & Chr(92) & s

А просто запустить макрос без перепечатывания не судьба?

Shersh · 09.02.2016, 14:37

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

Или можно так

Visual Basic
1
 s = ActiveWorkbook.Path & Chr(92) & s

Или так -

Visual Basic
1
  s = ActiveWorkbook.Path & "\" & s

@Alex77755 · 09.02.2016, 14:37

Не по теме:

Странно почему у меня не ругался макрос на отсутствие файла без этой добавленной строки.
Хотя должен был.

@blackeangel · 09.02.2016, 14:39 **[ТС]**

Alex77755, не ругайтесь, сижу с телефона и набираю с возможными ошибками. А сделал- распаковал архив, открыл файл пример_список и запустил макрос QVERT. Ничего не трогал. Да, именно на эту строку и ругается.

Добавлено через 1 минуту
А ругается, наверное, потому что у вас настройки другие наверняка. Библиотека дополнительно подключена каая-нибудь.

@Alex77755 · 09.02.2016, 14:43

Create<>greate

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

Кликните здесь для просмотра всего текста

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
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
 Sub QVERT()
    
 
        Dim arri(1)
        
        Dim s, wb, wbw As Workbook, G, ki, j, arr1, arr2, sWhatFind1, sWhatFind2, sWhatFind3, ncolumn, n, k, ncolumn1, ncolumn2, ncolumn3, массив
        Dim lc, lr, rx As Range, t, i, ri As Range
        Dim slm: Set slm = CreateObject("Scripting.Dictionary")
        Dim slmo: Set slmo = CreateObject("Scripting.Dictionary")
        s = Dir(ActiveWorkbook.Path & "\*.csv")
        If Len(s) > 0 Then
         s = ActiveWorkbook.Path & Chr(92) & s
            Set wbw = ActiveWorkbook
    
            Application.DisplayAlerts = False
            Application.ScreenUpdating = False
            arr1 = Split(CreateObject("Scripting.FileSystemObject").Getfile(s).OpenasTextStream(1).ReadAll, vbNewLine)
            arr2 = Split(arr1(0), ";")
            sWhatFind1 = "Обозначение"
            sWhatFind2 = "Маршрут общий"
            sWhatFind3 = "Маршрут"
'            находим колонки
            For i = 0 To UBound(arr2)
                If arr2(i) = sWhatFind1 Then ncolumn1 = i
                If arr2(i) = sWhatFind2 Then ncolumn2 = i
                If arr2(i) = sWhatFind3 Then ncolumn3 = i
            Next i
'            заливаем в словари
            For i = 1 To UBound(arr1)
                arr2 = Split(arr1(i), ";")
                If UBound(arr2) >= ncolumn2 Then
                    slmo(arr2(ncolumn1)) = arr2(ncolumn2)
                    slm(arr2(ncolumn1)) = arr2(ncolumn3)
                End If
            Next i
 
            
            With wbw.Worksheets(Лист1.Name)
                lc = .Cells(1, .Columns.Count).End(xlToLeft).Column
                lr = .Cells(.Rows.Count, 1).End(xlUp).Row
                массив = .Range("A1").Resize(lr, lc + 2)
            End With
 
            массив(1, 1) = sWhatFind1
            массив(1, 2) = sWhatFind2
            массив(1, 3) = sWhatFind3
                For i = 2 To UBound(массив)  'по 1 списку
                    t = массив(i, 1)
                    If slmo.exists(t) Then
                        массив(i, 2) = slmo(t)
                        массив(i, 3) = slm(t)
                     End If
                Next i
        
        End If
 
        
exitt:
 
        Лист3.Select
        Лист3.Cells.ClearContents
        Лист3.Range("A1").Resize(lr, lc + 2) = массив
        Лист3.Range("A1").Resize(lr, lc + 2).Columns.AutoFit
        Application.DisplayAlerts = True
        Application.ScreenUpdating = True
   End Sub

@blackeangel · 09.02.2016, 14:44 **[ТС]**

Alex77755, согласен, опечатка, но гугл клава решила иначе. Еше раз прошу прощения. Но проблема с
Dim slm: Set slm = CreateObject("Scripting.Dictionary") имеет решение?

@Alex77755 · 09.02.2016, 14:47

Ничего лишнего у меня не подключено.

@blackeangel · 09.02.2016, 15:05 **[ТС]**

Alex77755, вот принтскрины сделал, если не верите
https://cloud.mail.ru/public/28Sf/CVriUAJmc
В общем вариант со словарём у меня не работает.

@Alex77755 · 09.02.2016, 20:35

но гугл клава решила иначе

Могу предположить, что была попытка запустить макрос не на компе, а в каком-нибудь "облаке"...
Тут помочь не могу. Никогда с виртуальными таблицами не работал.
Единственное, что могу предложить: цикл в цикле как и было.
Чуть позже предложу код

Добавлено через 13 минут
Без словаря. Цикл в цикле

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
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
Option Explicit
    Sub QVERT()
    
         Dim arri(1)
        
        Dim s, wb, wbw As Workbook, G, ki, j, arr1, arr2, sWhatFind1, sWhatFind2, sWhatFind3, ncolumn, n, k, ncolumn1, ncolumn2, ncolumn3, массив
        Dim lc, lr, rx As Range, t, i, ri As Range
'        Dim slm: Set slm = CreateObject("Scripting.Dictionary")
'        Dim slmo: Set slmo = CreateObject("Scripting.Dictionary")
        s = Dir(ActiveWorkbook.Path & "\*.csv")
        If Len(s) > 0 Then
         Лист3.Cells.ClearContents
         s = ActiveWorkbook.Path & Chr(92) & s
            Set wbw = ActiveWorkbook
    
            Application.DisplayAlerts = False
            Application.ScreenUpdating = False
            arr1 = Split(CreateObject("Scripting.FileSystemObject").Getfile(s).OpenasTextStream(1).ReadAll, vbNewLine)
            arr2 = Split(arr1(0), ";")
            sWhatFind1 = "Обозначение"
            sWhatFind2 = "Маршрут общий"
            sWhatFind3 = "Маршрут"
'            находим колонки
            For i = 0 To UBound(arr2)
                If arr2(i) = sWhatFind1 Then ncolumn1 = i
                If arr2(i) = sWhatFind2 Then ncolumn2 = i
                If arr2(i) = sWhatFind3 Then ncolumn3 = i
            Next i
            
''            заливаем в словари
'            For i = 1 To UBound(arr1)
'                arr2 = Split(arr1(i), ";")
'                If UBound(arr2) >= ncolumn2 Then
'                    slmo(arr2(ncolumn1)) = arr2(ncolumn2)
'                    slm(arr2(ncolumn1)) = arr2(ncolumn3)
'                End If
'            Next i
 
            
            With wbw.Worksheets(Лист1.Name)
                lc = .Cells(1, .Columns.Count).End(xlToLeft).Column
                lr = .Cells(.Rows.Count, 1).End(xlUp).Row
                массив = .Range("A1").Resize(lr, lc + 2)
            End With
 
            массив(1, 1) = sWhatFind1
            массив(1, 2) = sWhatFind2
            массив(1, 3) = sWhatFind3
                For i = 2 To UBound(массив)  'по 1 списку
                    t = массив(i, 1)
                    For j = 1 To UBound(arr1)
                    arr2 = Split(arr1(j), ";")
                        If UBound(arr2) >= ncolumn2 Then
                            If arr2(ncolumn1) = t Then
                                массив(i, 2) = arr2(ncolumn2)
                                массив(i, 3) = arr2(ncolumn3)
                                Exit For
                            End If
                        End If
                    Next j
                Next i
        
        End If
exitt:
 
        Лист3.Select
        Лист3.Cells.ClearContents
        Лист3.Range("A1").Resize(lr, lc + 2) = массив
        Лист3.Range("A1").Resize(lr, lc + 2).Columns.AutoFit
        Application.DisplayAlerts = True
        Application.ScreenUpdating = True
   End Sub

@blackeangel · 10.02.2016, 08:08 **[ТС]**

Alex77755, ругается на:

Visual Basic
1
arr1 = Split(CreateObject("Scripting.FileSystemObject").Getfile(s).OpenasTextStream(1).ReadAll, vbNewLine)

Такой же ошибкой как и вчера.

@blackeangel · 10.02.2016, 08:12 **[ТС]**

Вот скриншоты с ошибкой

@blackeangel · 10.02.2016, 08:13 **[ТС]**

Так понимаю надо что то не содержащее

Visual Basic
1
CreateObject

Запуск производится на обычном стационарнике, без виртуалок, под управлением Windows XP. Возможно в этом и проблема, что ОС старая

Shersh · 10.02.2016, 08:25

blackeangel, есть много других способов читать файлы - вот пример, которым сам часто пользуюсь:

Visual Basic
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
Function Rd_File(fname As String) As String
Dim ff As Integer: ff = FreeFile
On Error Resume Next
Open fname For Binary As ff
If Err Then
  Rd_File = "Ошибка при открытии файла """ & fname & """ для чтения - " & Err.Number & ": " & Err.Description
  Exit Function
End If
Rd_File = String$(LOF(ff), vbNullChar)
Get #ff, , Rd_File
If Err Then
  Rd_File = "Ошибка при чтении файла " & fname & """ - " & Err.Number & ": " & Err.Description ': Exit Sub
End If
Close ff
If Err Then
  Rd_File = "Ошибка при закрытии файла " & fname & """ - " & Err.Number & ": " & Err.Description  ': Exit Function
End If
On Error GoTo 0
End Function

@Alex77755 · 10.02.2016, 10:59

У меня тоже ХРюша. Но работает.
Видимо, что-то в твоей системе "паламалася"
Замени строчку 18 на это:

Visual Basic
1
2
3
4
5
            Dim arri(1), CF As String    'объявим пеpеменнyю для имени файла и его cодеpжимого
            Open s For Binary As #1   'откpоем файл для чтения
               CF = Input(FileLen(s), 1) 'загpyзить в пеpеменyю CF вcе cодеpжимое файла
            Close #1 'закpыть файл
            arr1 = Split(CF, vbNewLine)

Проверил. работает. Результат выводит на Лист3. Наличие листа не проверяется: должен быть.
Остальное подпиливать под свои нужды (Ну там вставка колонок и в какие колонки выводить...)

@blackeangel · 10.02.2016, 15:23 **[ТС]**

Alex77755, заработало, спасибо огромное

Добавлено через 14 минут
А если вместо *.csv будет тхт? Без разницы?

Добавлено через 23 минуты
Ещё было бы не плохо дать комментарии к строкам, а то немного не понимаю жёсткую привязку к Range("А") и как заменить её на поисковую?

Добавлено через 2 часа 17 минут
Если пишу полный путь к файлу то ругается 52 ошибкой на строчку

Visual Basic
1
Open s For Binary As #1

Если что пишу так

Visual Basic
1
s="D:\Обмен\123.csv"

@Alex77755 · 10.02.2016, 20:40

А если вместо *.csv будет тхт? Без разницы?

Разница есть
Здесь проверяется наличие любого файла csv рядом с файлом с макросом

Visual Basic
1
s = Dir(ActiveWorkbook.Path & "\*.csv")

Если будет txt, то надо менять. А если надо, что бы мог обрабатывать и txt и csv, то надо немного переделать условия проверки.

то ругается 52 ошибкой на строчку

А был ли мальчик? Т.е. есть ли файл?
после назначения пути:

Visual Basic
1
s="D:\Обмен\123.csv"

Следует проверить хотя бы Dir.
Но лучше сделать выбор файла. Ибо прописывать путь в коде не есть хорошо
Рядом с рабочим файлом любой csv ещё куда ни шло

@blackeangel · 10.02.2016, 20:59 **[ТС]**

Alex77755, если пишу так

Visual Basic
1
s = Dir("D:\Обмен\123.csv")

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

Visual Basic
1
arr2 = Split(arr1(0), ";")

Причем этот же файл при

Visual Basic
1
s = Dir(ActiveWorkbook.Path & "\*.csv")

отрабатывает нормально.
И пути менял. Все равно либо то либо это. Файл создавался специально и клался туда откуда должен читаться.

Добавлено через 52 секунды
часть этого файла вы сами видели в приложении ранее, и ";" там были

Добавлено через 3 минуты
и как отвязать от привязки к диапазону "А" так и не понял. Точнее не понял как подменить...Cells и Range разного типа и одно на другое не подменишь. как то надо иначе.

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

Visual Basic
1
ncolumn = Cells.Find(What:=sWhatFind, After:=ActiveCell, SearchOrder:=xlByColumns).Column

то как же определить диапазон который "улетает" в массив?

@Alex77755 · 10.02.2016, 21:41

Visual Basic
1
s = Dir("D:\Обмен\123.csv")

Это проверка наличия файла
Но результат её будет короткое имя файла. Т.е. Обмен\123.csv" если путь верен и "" если файла нет
Т.е. наличие фала проверяется сравнением длины s с 0

Visual Basic
1
2
s = Dir("D:\Обмен\123.csv")
if Len(s)=0 then exit sub ' если файла нет, то выход из процедуры.

Так же можно добавить проверку на корректность файла. Т.е. есть ли в строках разделители ";"
Да много разных ошибок может быть

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

Visual Basic
1
ncolumn = Cells.Find(What:=sWhatFind, After:=ActiveCell, SearchOrder:=xlByColumns).Column

Определяет номер колонки с sWhatFind
А уж что загонять в массив надо назначать самому
В общем виде в массив загнать можно так
массив=Range(Cells(номер_строки_верх, номер_колонки_лев), Cells(Номер_строки_низ, Номер_колонки_прав)).Value

@blackeangel · 15.02.2016, 10:37 **[ТС]**

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
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
 Option Explicit
Sub QVERT()
Dim arri(1)
Dim s, wb, wbw As Workbook, G, ki, j, arr1, arr2, sWhatFind1, sWhatFind2, sWhatFind3, ncolumn, n, k, ncolumn1, ncolumn2, ncolumn3, массив
Dim lc, lr, rx As Range, t, i, ri As Range
Dim CF As String 'объявим пеpеменнyю для имени файла и его cодеpжимого
's = Dir(ActiveWorkbook.Path & "\*.csv")
s = "D:\123123.csv"
If Len(s) = 0 Then Exit Sub ' если s=0 то выходим
 
If Len(s) > 0 Then
'Лист3.Cells.ClearContents
s = ActiveWorkbook.Path & Chr(92) & s
Set wbw = ActiveWorkbook
 
' тормозим отрисовку ->
Application.DisplayAlerts = False
Application.ScreenUpdating = False
' <-
Open s For Binary As #1 'откpоем файл для чтения
CF = Input(FileLen(s), 1) 'загpyзить в пеpеменyю CF вcе cодеpжимое файла
Close #1 'закpыть файл
arr1 = Split(CF, vbNewLine)
arr2 = Split(arr1(0), ";")
' зададим что искать ->
sWhatFind1 = "Обозначение"
sWhatFind2 = "Маршрут общий"
sWhatFind3 = "Маршрут"
' <-
' находим колонки ->
For i = 0 To UBound(arr2)
If arr2(i) = sWhatFind1 Then ncolumn1 = i
If arr2(i) = sWhatFind2 Then ncolumn2 = i
If arr2(i) = sWhatFind3 Then ncolumn3 = i
Next i
' <-
 
With wbw.Worksheets(Лист1.Name)
lc = .Cells(1, .Columns.Count).End(xlToLeft).Column
lr = .Cells(.Rows.Count, 1).End(xlUp).Row
массив = .Range("A1").Resize(lr, lc + 2)
End With
 
'записываем в шапку Обозначение, Маршрут общий, Маршрут ->
массив(1, 1) = sWhatFind1
массив(1, 2) = sWhatFind2
массив(1, 3) = sWhatFind3
' <-
 
For i = 2 To UBound(массив) 'по 1 списку
t = массив(i, 1)
For j = 1 To UBound(arr1)
arr2 = Split(arr1(j), ";")
If UBound(arr2) >= ncolumn2 Then
If arr2(ncolumn1) = t Then
массив(i, 2) = arr2(ncolumn2)
массив(i, 3) = arr2(ncolumn3)
Exit For
End If
End If
Next j
Next i
End If
exitt:
'Лист3.Select
'Лист3.Cells.ClearContents
 
ActiveSheet.Range("A1").Resize(lr, lc + 2) = массив
 
'ActiveSheet.Range("A1").Resize(lr, lc + 2).Columns.AutoFit
' отрисовываем результат ->
Application.DisplayAlerts = True
Application.ScreenUpdating = True
' <-
End Sub

для меня остались тёмные участки:
1) что делает это:

Visual Basic
1
2
3
4
 If Len(s) > 0 Then
'Лист3.Cells.ClearContents
s = ActiveWorkbook.Path & Chr(92) & s
Set wbw = ActiveWorkbook

2) что делает это:

Visual Basic
1
2
3
4
5
With wbw.Worksheets(Лист1.Name)
lc = .Cells(1, .Columns.Count).End(xlToLeft).Column
lr = .Cells(.Rows.Count, 1).End(xlUp).Row
массив = .Range("A1").Resize(lr, lc + 2)
End With

3) что делает это:

Visual Basic
1
ActiveSheet.Range("A1").Resize(lr, lc + 2) = массив

Далее по Range...
типа так:

Visual Basic
1
2
ncolumn = Cells.Find(What:=sWhatFind, LookIn:=xlValues, LookAt:=xlWhole, SearchOrder:=xlByColumns).Column
массив = Range(Cells(1,ncolumn-1),Cells(Cells(Rows.Count,ncolumn+1).End(xlUp).Row),ncolumn+1)

@Alex77755 · 15.02.2016, 12:09

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
'начальный вариант был такой
s = Dir(ActiveWorkbook.Path & "\*.csv") ' проверяем наличие файла *.csv рядом с книгой
If Len(s) = 0 Then Exit Sub ' если такого файла нет (s=0) то выходим
 
Лист3.Cells.ClearContents 'очищаем Лист3
s = ActiveWorkbook.Path & Chr(92) & s ' назначаем путь файла *.csv
Set wbw = ActiveWorkbook 'назначаем объектную переменную = активной книге
 
With wbw.Worksheets(Лист1.Name) 'выбираем для работы 1 лист актиыной книги
    lc = .Cells(1, .Columns.Count).End(xlToLeft).Column 'определяем колисество заполненных столбцов в 1 строке
    lr = .Cells(.Rows.Count, 1).End(xlUp).Row 'определяем количество заполненных строк в 1 колонке
    массив = .Range("A1").Resize(lr, lc + 2) ' грузим в массив добавляя в массиве 2 колонки для вывода результата
End With
 
 
ActiveSheet.Range("A1").Resize(lr, lc + 2) = массив ' Выгружаем массив на лист. Уже с результатами
 
'На счёт Range, Find
'Если я работаю с массивами, то, как правило, не использую функции листа. А в массиве метод Find не работает
'Ну а, в принципе, да. Если таблица широкая, то лишнее можно не брать.
'Только вот почему
массив = Range(Cells(1,ncolumn-1
'Так в массиве будет только предыдущая колонка, а искать же нужно по 1. И не факт, что sWhatFind находится во 2 колонке

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

Visual Basic
1
2
3
' определяем номер колонки с sWhatFind
ncolumn = Cells.Find(What:=sWhatFind, LookIn:=xlValues, LookAt:=xlWhole, SearchOrder:=xlByColumns).Column
массив = Range(Cells(1,ncolumn-1),Cells(Cells(Rows.Count,ncolumn+1).End(xlUp).Row),ncolumn+1)

А в массив почему-то берём область с первой строки и предыдущей колонки от sWhatFind до количества строк в колонке следующей за колонкой с sWhatFind (Rows.Count,ncolumn+1). А она вообще-то заполнена? А первую, в которой искать надо не берём. Как-то не вяжется.

Новые блоги и статьи Все статьи Все блоги /
Nekobox - outbounds[0].transport: unknown transport type: raw damix 01.10.2026 Фикс ошибки Правым кликом по серверу -> отладочная информация -> edit Заменить "net": "raw", на "net": "tcp", Нажать кнопку reload.	Программный домашний кинотеатр 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. Опрашиваются регистры. . .	Hyper-V: Компьютер должен поддерживать доверенный платформенный модуль 2.0. Maks 31.08.2026 При установке Windows 11 на виртуальную машину Hyper-V 2-го поколения вылезла такая ошибка: Решение: в параметрах виртуальной машины, в разделе "Безопасность" (Security) активировать флаг. . .

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

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

@Alex77755
	09.02.2016, 14:37
	Не по теме: Странно почему у меня не ругался макрос на отсутствие файла без этой добавленной строки. Хотя должен был. 0

@blackeangel 19 / 10 / 1 Регистрация: 22.07.2015 Сообщений: 908
	09.02.2016, 14:39 [ТС]
	Alex77755, не ругайтесь, сижу с телефона и набираю с возможными ошибками. А сделал- распаковал архив, открыл файл пример_список и запустил макрос QVERT. Ничего не трогал. Да, именно на эту строку и ругается. Добавлено через 1 минуту А ругается, наверное, потому что у вас настройки другие наверняка. Библиотека дополнительно подключена каая-нибудь. 0

@blackeangel 19 / 10 / 1 Регистрация: 22.07.2015 Сообщений: 908
	09.02.2016, 14:44 [ТС]
	Alex77755, согласен, опечатка, но гугл клава решила иначе. Еше раз прошу прощения. Но проблема с Dim slm: Set slm = CreateObject("Scripting.Dictionary") имеет решение? 0

@Alex77755 11525 / 3812 / 683 Регистрация: 13.02.2009 Сообщений: 11,229
	09.02.2016, 14:47
	Ничего лишнего у меня не подключено. 0

@blackeangel 19 / 10 / 1 Регистрация: 22.07.2015 Сообщений: 908
	09.02.2016, 15:05 [ТС]
	Alex77755, вот принтскрины сделал, если не верите https://cloud.mail.ru/public/28Sf/CVriUAJmc В общем вариант со словарём у меня не работает. 0

@blackeangel 19 / 10 / 1 Регистрация: 22.07.2015 Сообщений: 908
	10.02.2016, 08:12 [ТС]
	Вот скриншоты с ошибкой Миниатюры 0