Компьютерный форум OSzone.net  

Компьютерный форум OSzone.net (http://forum.oszone.net/index.php)
-   Microsoft Office (Word, Excel, Outlook и т.д.) (http://forum.oszone.net/forumdisplay.php?f=115)
-   -   [решено] Создание макроса для поиска одинаковых значений в ячейках и укомплектовывания (http://forum.oszone.net/showthread.php?t=294196)

dyshes90 20-01-2015 17:32 2458919
Создание макроса для поиска одинаковых значений в ячейках и укомплектовывания
 
Вложений: 2
Доброго времени суток уважаемые форумчане.
Существует проблема в написании макроса в Excel.
Честно говоря я немного далек от этого, лет 5 не занимался подобным и тупо все забыл.
Необходимо создать макрос для поиска и сортировки наименований таблицы и записывать их в отдельные строки.
Пример, как это должно быть в пристежке.
Т.е. макрос должен найти одинаковые значения во всем столбце (до 100 строк) и перенести наименование, ячейку и количество, для каждого наименования отдельно.
Люди добрые, помогите кто чем может)) Может кто писал подобное....

Iska 20-01-2015 18:16 2458939
dyshes90, ничего не понятно. Где в Вашем примере находится:
Цитата:
Цитата dyshes90
во всем столбце (до 100 строк) »
?

dyshes90 21-01-2015 09:47 2459174
Это столбец С, там могут находиться до 100 наименований.

Iska 21-01-2015 10:39 2459186
dyshes90, ну, так покажите какой-нибудь реальный пример. Ибо в том, что Вы привели, нет никаких повторов, и совершенно непонятно, откуда берётся «1», и откуда — «8».

dyshes90 21-01-2015 11:54 2459212
Вложений: 1
Вот что-то подобное, физических ячеек к которым привязывается программа максимум будет 16, наименований в каждой вплоть до 100, макрос должен просканировать все значения наименования, найти одинаковые и запихнуть в отдельную табличку с указанием количества и к какой ячейке принадлежит

Iska 21-01-2015 12:01 2459215
dyshes90, примерно ясно. Только выложите то же самое в виде документа, а не изображения.

dyshes90 21-01-2015 12:55 2459236
Вложений: 1
Пожалуйста.

dyshes90 22-01-2015 17:18 2459785
Товарищи форумчане, есть ли мысли по этому вопросу или глухо все как в танке?

Iska 23-01-2015 06:00 2460011
Мысли есть. Дело осталось за малым: начать и закончить ;). То есть — проверить, возможна ли корректная реализация этих мыслей.

a_axe 23-01-2015 10:44 2460089
Вложений: 1
dyshes90, я прошу прощения - а почему именно VBA, сводная таблица не подойдет?
Не скажу, что сильно "шуруплю" в сводных таблицах - но на первый взгляд вроде то, что Вы хотите. Или такая форма не подходит?

Iska 23-01-2015 20:12 2460378
a_axe, на мой взгляд — вполне подойдёт. Но подождём мнения автора.

dyshes90 26-01-2015 10:02 2461423
Доброго дня, сводная таблица впр не плохо, я рассматривал этот вариант, но в примере всего 3 ячейки, на деле их будет 16-20, не совсем удобно просматривать данные будет на ней, всетки с моим примером по проще.

dyshes90 26-01-2015 15:14 2461607
Iska, Есть идеи какие-нибудь, сроки горят, начальство вазилин готовит для меня)

Iska 26-01-2015 15:20 2461609
dyshes90, я не вижу, чем бы это было неудобно.

Цитата:
Цитата dyshes90
Iska, Есть идеи какие-нибудь »
Есть. Использовать предложенный вариант со сводной таблицей.

dyshes90 26-01-2015 15:41 2461627
Iska, Нет, не катит, вариант не удачный, неудобный для работы. Закрываю тему если мыслей нет.....

a_axe 26-01-2015 16:16 2461642
Вложений: 1
Цитата:
Цитата dyshes90
не совсем удобно просматривать данные будет на ней »
Что именно неудобно и как нужно изменить, чтобы стало удобно?

Цитата:
Цитата dyshes90
на деле их будет 16-20 »
действительно, к Вам даже просьба была в этой связи:
Цитата:
Цитата Iska
dyshes90, ну, так покажите какой-нибудь реальный пример. »
Как вариант - можно сделать 26 сводных (бред конечно, но раз возникло расплывчатое слово "удобно") сводных таблиц по одной на каждого смурфика-фиксика в стиле Вашего файла (вообще четких критериев Вы не дали, поэтому совпадение условное) - в приложенном файле зеленые таблички. Сразу говорю, что замучаетесь их обновлять при изменении данных.

Ну и промежуточный (нормальный ) вариант - сделать все же одну сводную таблицу слегка в другой компоновке (в приложенном файле синяя таблица). В ней нажатием на крестик можно разворачивать/сворачивать наименование фильма. Нужна позиция - развернули, не нужна - свернули. Обновлять ее нужно только один раз.

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

dyshes90 26-01-2015 17:39 2461695
Вложений: 1
a_axe, Спасибо огромное за вариант, но сделал удобнее, раскидал каждое наименование на отдельный лист, сыровато получилось, но удобнее для работы на данный момент, буду добивать, если есть желание помочь, буду весьма признателен. Вот полурабочий файл.

Iska 27-01-2015 11:23 2462010
dyshes90, мой вариант извлечения — посредством OLE DB (Office 2003):
Код:
Sub Sample()
    Dim objConnection As Object
    Dim objRecordSet1 As Object
    Dim objRecordSet2 As Object
   
    Dim objCurRegion As Range
   
   
    Set objConnection = CreateObject("ADODB.Connection")
   
    With objConnection
        .Provider = "Microsoft.Jet.OLEDB.4.0"
        .ConnectionString = _
            "Data Source=" & ThisWorkbook.FullName & ";" & _
            "Extended Properties=""Excel 8.0;HDR=Yes;"""
        .Open
    End With
   
    Set objCurRegion = ThisWorkbook.Worksheets.Item("Адресная программа").Range("B2").CurrentRegion
   
    Set objRecordSet1 = objConnection.Execute( _
            "SELECT DISTINCT Наименование " & _
            "FROM [Адресная программа$" & objCurRegion.Address(False, False) & "] " & _
            "WHERE NOT Наименование IS NULL ORDER BY Наименование" _
        )
   
    Set objRecordSet2 = objConnection.Execute( _
            "SELECT Наименование, Ячейки, Количество " & _
            "FROM [Адресная программа$" & objCurRegion.Address(False, False) & "] " & _
            "WHERE NOT Наименование IS NULL ORDER BY Наименование, Ячейки" _
        )
   
    Do Until objRecordSet1.EOF
        Debug.Print objRecordSet1.Fields.Item("Наименование").Value
       
        With objRecordSet2
            .Filter = "Наименование='" & objRecordSet1.Fields.Item("Наименование").Value & "'"
           
            Do Until .EOF
                With .Fields
                    Debug.Print vbTab, .Item("Ячейки").Value, vbTab, .Item("Количество").Value
                End With
               
                .MoveNext
            Loop
        End With
       
        objRecordSet1.MoveNext
    Loop
   
    Set objCurRegion = Nothing
   
    objRecordSet2.Close
    objRecordSet1.Close
   
    objConnection.Close
   
    Set objRecordSet2 = Nothing
    Set objRecordSet1 = Nothing
   
    Set objConnection = Nothing
End Sub
Необходимые условия: Рабочая книга должна быть сохранена (обращение идёт именно к файлу Рабочей книги, а не к открытой в Excel Рабочей книге, не к текущим и не сохранённым изменениям); столбец «Ячейки» должен быть заполнен значениями (т.е., не как в первом выложенном Вами варианте).

В коде присутствует жёсткая привязка к адресу — «B2», откуда берётся текущий диапазон для извлечения. Первый запрос («objRecordSet1») извлекает все уникальные Наименования, второй («objRecordSet2») — весь диапазон целиком. Затем происходит вывод второго запроса с группировкой строк по строкам первого запроса. Для упрощения понимания вывод делается в окно отладки («Ctrl-G»), без формирования вывода в ячейки.

dyshes90 27-01-2015 11:27 2462016
Iska, спасибо!!! Пример в студию please)

Iska 27-01-2015 12:49 2462080
Вложений: 1
dyshes90, дык, на Вашем же файле делал. Только дозаполнил по паре отсутствующих значений в столбцах «Ячейки» и «Количество»: Файл 121538.

На всякий случай повторюсь: вывод идёт в окно отладки «Immediate», нажмите «Alt-F11», затем «Ctrl-G».

dyshes90 27-01-2015 12:59 2462089
Iska, На самом деле круто, спасибо, только нужно чтобы это все графически выводилось, а не в окне отладки.

Iska 27-01-2015 13:18 2462107
Если опишете и покажете, как именно надо — попробуем. Сразу скажу, что вариант «Всё на том же листе в виде подтаблиц» мне не сильно нравится.

Конечная цель этих действий какова вообще?

dyshes90 27-01-2015 15:58 2462208
Вложений: 1
Я скинул файл вчера, как сам навоял, я таблицу раскидал по разным листам......было бы не плохо, чтобы макрос выкидвал эту таблицу на другой лист в таком примерно виде

Iska 27-01-2015 17:31 2462248
Попробуйте так (замените существующую процедуру «Sample()»):
Скрытый текст
Код:
Sub Sample()
    Dim objConnection As Object
    Dim objRecordSet1 As Object
    Dim objRecordSet2 As Object
   
    Dim objCurRegion As Range
   
    Dim objWorksheet As Worksheet
    Dim objRange As Range
   
   
    Set objConnection = CreateObject("ADODB.Connection")
   
    With objConnection
        .Provider = "Microsoft.Jet.OLEDB.4.0"
        .ConnectionString = _
            "Data Source=" & ThisWorkbook.FullName & ";" & _
            "Extended Properties=""Excel 8.0;HDR=Yes;"""
        .Open
    End With
   
    Set objCurRegion = ThisWorkbook.Worksheets.Item("Адресная программа").Range("B2").CurrentRegion
   
    Set objRecordSet1 = objConnection.Execute( _
            "SELECT DISTINCT Наименование " & _
            "FROM [Адресная программа$" & objCurRegion.Address(False, False) & "] " & _
            "WHERE NOT Наименование IS NULL ORDER BY Наименование" _
        )
   
    Set objRecordSet2 = objConnection.Execute( _
            "SELECT Наименование, Ячейки, Количество " & _
            "FROM [Адресная программа$" & objCurRegion.Address(False, False) & "] " & _
            "WHERE NOT Наименование IS NULL ORDER BY Наименование, Ячейки" _
        )
   
    objRecordSet1.MoveFirst
   
    Set objWorksheet = ThisWorkbook.Worksheets.Add()
    Set objRange = objWorksheet.Range("A1")
   
    Do Until objRecordSet1.EOF
        Set objCurRegion = objRange
        objRange.Value = objRecordSet1.Fields.Item("Наименование").Value
       
        With objRecordSet2
            .Filter = "Наименование='" & objRecordSet1.Fields.Item("Наименование").Value & "'"
           
            Do Until .EOF
                With .Fields
                    objRange.Offset(0, 1).Value = .Item("Ячейки").Value
                    objRange.Offset(0, 2).Value = .Item("Количество").Value
                End With
               
                .MoveNext
               
                Set objCurRegion = Union(objCurRegion, objRange, objRange.Offset(0, 1), objRange.Offset(0, 2))
                Set objRange = objRange.Offset(1, 0)
            Loop
        End With
       
        With objCurRegion.Borders
            .LineStyle = xlContinuous
            .Weight = xlThin
            .ColorIndex = xlAutomatic
        End With
       
        With objCurRegion.Columns.Item(1)
            .Merge
           
            .HorizontalAlignment = xlCenter
            .VerticalAlignment = xlCenter
        End With
       
        objRecordSet1.MoveNext
       
        Set objRange = objRange.Offset(1, 0)
    Loop
   
    objWorksheet.Columns("A:C").AutoFit
   
    Set objRange = Nothing
    Set objCurRegion = Nothing
    Set objWorksheet = Nothing
   
    objRecordSet2.Close
    objRecordSet1.Close
   
    objConnection.Close
   
    Set objRecordSet2 = Nothing
    Set objRecordSet1 = Nothing
   
    Set objConnection = Nothing
End Sub

dyshes90 28-01-2015 10:19 2462537
Вложений: 1
Iska, Хорошо, будь другом, подскажи если знаешь, как сделать, надо закрасить ячейки на против цифр, причем диапазон цифр может меняться, нужна процедура, при нажатии на кнопку он просматривал столбец находил цифру 1 и закрашивал рядом стоящую ячейку

dyshes90 28-01-2015 11:15 2462558
У же не надо, сам решил, спасибо)

Iska 28-01-2015 13:06 2462595
Цитата:
Цитата dyshes90
У же не надо, сам решил, спасибо) »
Это хорошо, потому как я ничего толком не понял ;).


Время: 23:33.

Время: 23:33.
© OSzone.net 2001-