2010 - "Прикрутить" столбец из другого файла с условием

a_axe · Конфигурация компьютера

Цитата Iska:

ещё более конструктивное предложение »

Iska, ну да, по раздумью - единственное что стоило бы посоветовать в данном случае

. Однако TS отверг базы как тогда, так и ожидаемо сейчас - отредактировав свой пост №9 в этом топике

Судя по всему - массивы более компромиссный вариант, правда непонятно, как они тут помогут

.

blackeangel · Отправлено: **18:50, 01-02-2016** | #12

Цитата a_axe:

Судя по всему - массивы более компромиссный вариант, правда непонятно, как они тут помогут

.

По моему мнению(а может и заблуждению) создав массив из нужных колонок(хотя как вариант скопировав нужные колонки на новый лист) с ним будет проще работать в памяти.

На счёт того что отверг-каково задание дали мне, так я его и выложил. Не моя прихоть.
А так спасибо за лестные слова

a_axe · Конфигурация компьютера

Оффтоп

Цитата blackeangel:

когда работа будет например с 1,5 млн строк в которых примерно 40 столбцов, тогда перебор увы не покатит. »

Разумеется - сделать указанную рабочую книгу просто-напросто не получится, смотрите тут. Если подобрать грамотный алгоритм, будет совершенно без разницы 40 у вас колонок или 2000.

Цитата blackeangel:

А так спасибо за лестные слова »

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

Цитата blackeangel:

Сейчас в меня полетят какашки по поводу что тут надо »

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

В мое советское школьное детство преподаватели вбили одну незатейливую истину: правильно и грамотно оформленные условия задачи являются ровно половиной ее решения.
Что нужно делать у вас - извините, абсолютно для меня не понятно.

Цитата blackeangel:

Ах да, и как оказалось, столбцов из базы(2 файл) надо брать 3... »

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

Цитата blackeangel:

И располагаются они хаотично.. »

Это следует показать в примере, если необходимо - в нескольких.

Цитата blackeangel:

учитывает только первую входимость, а надо все... »

Что такое первая входимость? Как ее нужно учитывать - записывать одинаковые строчки, или есть некий алгоритм как их различать?

Цитата blackeangel:

Необходимо к перечню 1го файла прикрутить тот столбец что во втором файле, »

Как следует понимать слово "прикрутить"?
Еще раз терпеливо вам объясняю: отсутствие внятной постановки задачи с большой долей вероятности делает невозможным ее решение. Опишите хотя бы Ваше виденье алгоритма: "обработчик в исходном файле ищет ячейку с содержимым "Инструм.", получает номер столбца, перебирает в нем все непустые ячейки, ищет значение каждой из этих ячеек во втором файле, если нашел - копирует значения из столбцов с заголовками такими-то..." и т.д. Вы это формулируете в виде "нужно прикрутить", а что конкретно делать нужно - в общем-то не понятно.
Привожу свое интуитивное виденье кода, который вероятно вам нужен. Если вы его просто проигнорируете - как первый код, будто его и не было - возьму самоотвод от участия в этой теме. Запускать код нужно при активном документе, куда вы хотите копировать данные. Открыты д.б. оба документа.

код

Код:

Public Sub osn()
    Dim dataBook As Workbook
    Dim dataSheet As Worksheet
    Dim myCell As Range
    Dim i As Long, j As Long, k As Long, m As Long, n As Long
    If Application.Workbooks.Count = 2 Then
        For Each dataBook In Application.Workbooks
            If dataBook.Name <> ThisWorkbook.Name Then Set dataSheet = dataBook.ActiveSheet
            
        Next
        i = dataSheet.Rows(1).Find(What:="№ детали", LookIn:=xlValues, LookAt:=xlPart, SearchOrder:=xlByRows).Column
        j = dataSheet.Rows(1).Find(What:="Инструм.", LookIn:=xlValues, LookAt:=xlPart, SearchOrder:=xlByRows).Column
        k = dataSheet.Rows(1).Find(What:="Год", LookIn:=xlValues, LookAt:=xlPart, SearchOrder:=xlByRows).Column
        m = ActiveSheet.Rows(1).Find(What:="Обозначение", LookIn:=xlValues, LookAt:=xlPart, SearchOrder:=xlByRows).Column
        Debug.Print dataSheet.Name
        Debug.Print i & " " & j & " " & k & " " & m
        For Each myCell In Intersect(ActiveWorkbook.ActiveSheet.UsedRange, ActiveWorkbook.ActiveSheet.Columns(m))
            On Error Resume Next
            Err.Clear
            n = Application.WorksheetFunction.Match(myCell.Value, Range(dataSheet.Cells(1, i), dataSheet.Cells(dataSheet.UsedRange.Count, i)), 0)
            myCell.Offset(0, 1).Value = Application.WorksheetFunction.Index(Range(dataSheet.Cells(1, j), dataSheet.Cells(dataSheet.UsedRange.Count, j)), n)
            myCell.Offset(0, 2).Value = Application.WorksheetFunction.Index(Range(dataSheet.Cells(1, k), dataSheet.Cells(dataSheet.UsedRange.Count, k)), n)
            
            If Err.Number <> 0 Then
                myCell.Offset(0, 1).Value = ""
                myCell.Offset(0, 2).Value = ""
            End If
            
        Next
        ActiveWorkbook.ActiveSheet.Cells(1, m).Value = "Обозначение"
    Else
        MsgBox "Должно быть открыто 2 файла."
    End If
    Set dataSheet = Nothing
End Sub

blackeangel · Отправлено: **10:08, 03-02-2016** | #14

Итак, по коду - постоянно ругается, что не открыты 2 файла, хотя открыты оба и кроме них больше ничего.
В общем задание утряслось и есть чёткие требования. Прикладываю файлы. В первом на первом листе список, на втором итого,что должно получиться. В 2файле несколько вариантов "базы" откуда берутся данные.
Уточню ещё один момент, если имеет значение - winXP, office 2010.

a_axe · Конфигурация компьютера

Цитата blackeangel:

Итак, по коду - постоянно ругается что не открыты 2 файла, хотя открыты оба и кроме их больше ничего. »

попробуйте запустить вариант кода ниже, он перечислит по очереди все открытые файлы в сообщении.

код с проверкой

Код:

Public Sub osn()
    Dim dataBook As Workbook
    Dim dataSheet As Worksheet
    Dim myCell As Range
    Dim i As Long, j As Long, k As Long, m As Long, n As Long, Ik As Integer
    For Each dataBook In Application.Workbooks
        Ik = Ik + 1
        MsgBox "Открыто " & Application.Workbooks.Count & " рабочих книг, №" & Ik & " - " & dataBook.Name
    Next
    If Application.Workbooks.Count = 2 Then
        For Each dataBook In Application.Workbooks
            If dataBook.Name <> ThisWorkbook.Name Then Set dataSheet = dataBook.ActiveSheet
            
        Next
        i = dataSheet.Rows(1).Find(What:="№ детали", LookIn:=xlValues, LookAt:=xlPart, SearchOrder:=xlByRows).Column
        j = dataSheet.Rows(1).Find(What:="Инструм.", LookIn:=xlValues, LookAt:=xlPart, SearchOrder:=xlByRows).Column
        k = dataSheet.Rows(1).Find(What:="Год", LookIn:=xlValues, LookAt:=xlPart, SearchOrder:=xlByRows).Column
        m = ActiveSheet.Rows(1).Find(What:="Обозначение", LookIn:=xlValues, LookAt:=xlPart, SearchOrder:=xlByRows).Column
        Debug.Print dataSheet.Name
        Debug.Print i & " " & j & " " & k & " " & m
        For Each myCell In Intersect(ActiveWorkbook.ActiveSheet.UsedRange, ActiveWorkbook.ActiveSheet.Columns(m))
            On Error Resume Next
            Err.Clear
            n = Application.WorksheetFunction.Match(myCell.Value, Range(dataSheet.Cells(1, i), dataSheet.Cells(dataSheet.UsedRange.Count, i)), 0)
            myCell.Offset(0, 1).Value = Application.WorksheetFunction.Index(Range(dataSheet.Cells(1, j), dataSheet.Cells(dataSheet.UsedRange.Count, j)), n)
            myCell.Offset(0, 2).Value = Application.WorksheetFunction.Index(Range(dataSheet.Cells(1, k), dataSheet.Cells(dataSheet.UsedRange.Count, k)), n)
            
            If Err.Number <> 0 Then
                myCell.Offset(0, 1).Value = ""
                myCell.Offset(0, 2).Value = ""
            End If
            
        Next
        ActiveWorkbook.ActiveSheet.Cells(1, m).Value = "Обозначение"
    Else
        MsgBox "Должно быть открыто 2 файла."
    End If
    Set dataSheet = Nothing
End Sub

Отпишитесь по результату, сколько он показывает файлов. Либо можно определить имя файла, из которого будет выполняться копирование.

blackeangel · Отправлено: **11:43, 03-02-2016** | #16

Показал верно, отработал криво, не учитывал первые строки. Осталось оформить как в примере на листе итого в предыдущем посте.

blackeangel · Отправлено: **09:02, 08-02-2016** | #17

Пытался сделать из вашего кода чтобы читал из файла не получилось

Код:

Sub osn()
Dim myCell As Range
Application.ScreenUpdating = False
k = "D:\Обмен\МИПУ.xlsx"
Set s = GetObject(k)
Set i = s.Worksheets(1).Rows(1).Find(What:="Обозначение", LookIn:=xlValues, LookAt:=xlPart, SearchOrder:=xlByColumns)
mckoboz = i.Column
Set j = s.Worksheets(1).Rows(1).Find(What:="Маршрут", LookIn:=xlValues, LookAt:=xlWhole, SearchOrder:=xlByColumns)
mck = j.Column
Set m = ActiveSheet.Rows(1).Find(What:="Обозначение", LookIn:=xlValues, LookAt:=xlPart, SearchOrder:=xlByColumns)
dceoboz = m.Column

For Each myCell In Intersect(ActiveWorkbook.ActiveSheet.UsedRange, s.Worksheets(1).Columns(dceoboz))
On Error Resume Next
n = Application.WorksheetFunction.Match(myCell.Value, Range(s.Worksheets(1).Cells(1, mckoboz), s.Worksheets(1).Cells(s.Worksheets(1).UsedRange.Count, mckoboz)), 0)
myCell.Offset(0, 1).Value = Application.WorksheetFunction.Index(Range(s.Worksheets(1).Cells(1, mck), s.Worksheets(1).Cells(s.Worksheets(1).UsedRange.Count, mck)), n)
Next
s.Close SaveChanges:=False
Application.ScreenUpdating = True
End Sub

Где накосячил?