Поиск  Пользователи  Правила  Войти
Форумы "Планета Excel" » Вопросы по Microsoft Excel
Страницы: 1
RSS
Копирование данных с таблицы по условию с другой таблицы
 
#1
29.12.2019 00:36:50
Здравствуйте, пытаюсь написать макрос для копирования по условию, вроде все просто но не совсем. Есть большая база данных с клиентами и их email, столбец 1-email, 2- фамилия, 3-образование, 4-опыт работы, итого 8 столбцов. Email повторяются, если у человека 3 предыдущих работы, то будет 3 строки, с одинаковым email в 1 столбце. Есть список email от руководства, выбрать клиентов по этому списку, с всеми строками с одинаковым email. То есть, если из списка руководства email совпадает с базой клиентов, то скопировать все строки с одинаковім email на другой лист. База данных 60 тыс строк, список от руководства - 400 email. Итог может получится 900 строк (400 адресов, у каждого по 2-3 образования или 2-3 предыдущих работы). В приложении образец. Data - большой список данных на 60 тыс строк, Запрос - список адресов от руководства, Result - пример, что должно из этого получится. Спасибо
 
 
 
#2
29.12.2019 02:56:08
Код
Sub SelectAddress()
  Dim rg As Range, Cnt&, R1&, R2&, R3&
  Set rg = Worksheets(1).[a1].CurrentRegion:  SortRangeBy rg, Array(1), True
  With Worksheets(2)
    R2 = .Cells(Rows.Count, 1).End(xlUp).Row
    If R2 > 2 Then .Rows(2).Resize(R2 - 1).ClearContents
    R3 = 1: R2 = 2
    Do While Not IsEmpty(Cells(R3, 1))
      Cnt = WorksheetFunction.CountIf(Worksheets(1).Columns(1), Cells(R3, 1))
      If Cnt > 0 Then
        Set rg = Worksheets(1).Columns(1).Find(Cells(R3, 1), , xlValues, xlWhole, Searchformat:=False)
        If Not rg Is Nothing Then rg.Resize(Cnt, 1).EntireRow.Copy Worksheets(2).Cells(R2, 1): R2 = R2 + Cnt
      End If
      R3 = R3 + 1
    Loop
  End With
End Sub
Программисты - это люди, решающие проблемы, о существовании которых Вы не подозревали, методами, которых Вы не понимаете!
 
 
 
#3
29.12.2019 05:32:34
Цитата
Dodger-j написал:
База данных 60 тыс строк
С таким количеством данных подумать бы уже о "ADO" или "QueryTables" ? Например:
Код
Option Explicit

Sub karusel()
    Dim r&
    Dim adrs$, dbPath$, strCon$, strSql$ ', dbDefaultDir$ '=> Variant 2
    Dim cel As Range
    Dim fldnms As Boolean: fldnms = True
    
    Application.ScreenUpdating = False
    With ThisWorkbook
        .Sheets("Result").Range("A1").CurrentRegion.ClearContents
        
        'dbDefaultDir = .Path '=> Variant 2
        dbPath = .FullName
        
        With .Sheets("Zapros")
            adrs = .Range("A1:A" & .Cells(.Rows.Count, "A").End(xlUp).Row).Address
        End With
        
        For Each cel In .Sheets("Zapros").Range(adrs).Cells
            strSql = "SELECT * FROM [Data$] WHERE [Email] = '" & cel.Text & "';"
            
            ' ---- Variant 1 ----
            strCon = "ODBC;DSN=Excel Files;DBQ=" & dbPath & ";"
            ' ---- Variant 2 ----
            'strCon = "ODBC;DSN=Excel Files;DBQ=" & dbPath & ";" & _
            "DefaultDir=" & dbDefaultDir & ";DriverId=1046;MaxBufferSize=2048;PageTimeout=5;"
            '---------------------
            'Yesli budut problemy:
            '1. izmenite "Excel Files" v 'DSN' na imya, kotoroye u vas yest' v vashey sisteme
            ' =>    'DSN=Excel Files'    <=
            '2. prover'te nomer drayvera 'DriverId=1046', mozhet byt' naprimer 'DriverId=790'
            '---------------------
            With .Sheets("Result")
                With .QueryTables.Add(Connection:=strCon, Destination:=.Range("A1").Offset(r, 0), Sql:=strSql)
                    .AdjustColumnWidth = False
                    .FieldNames = fldnms
                    .PreserveFormatting = False
                    .RefreshStyle = xlInsertEntireRows
                    .Refresh BackgroundQuery:=False
                    .Delete
                End With
                r = .Cells(.Rows.Count, "A").End(xlUp).Row
                If r > 0 And fldnms Then fldnms = False
            End With
        Next
        .Sheets("Result").Range("A1").CurrentRegion.EntireColumn.AutoFit
    End With
    Application.ScreenUpdating = True
End Sub
Только с вашей кириллицей "QT" не хотело мне работать - но возможно с вашими драйверами будет.
 
 
 
#4
29.12.2019 12:32:39
Спасибо всем, первый вариант работает, второй вариант сегодня попробую, уверен тоже сработает. Спасибо всем. С наступающими праздниками.
 
 
 
#5
29.12.2019 13:01:22
Цитата
ocet p написал:
For Each cel In .Sheets("Zapros").Range(adrs).Cells            strSql = "SELECT * FROM [Data$] WHERE [Email] = '" & cel.Text & "';"
Это называется измучить запросами. Тут же зарос из двух таблиц и всё
Просто наклацал MSQuery
По вопросам из тем форума, личку не читаю.
 
 
 
#6
29.12.2019 15:37:24
:)
Ну что ж, в 3:30 утра вопросов больше чем ответов.
Я так "много" думал об QT, что SQL "сбежал".
Так например Ваш SQL для Dodger-j:
Код
Option Explicit

Sub Ne_karusel()
    Application.ScreenUpdating = False
    With ThisWorkbook
        With .Sheets("Result")
            .Range("A1").CurrentRegion.ClearContents
            
            Dim strCon$: strCon = "ODBC;DSN=Excel Files;DBQ=" & .Parent.FullName & ";"
            Dim unvrsl: unvrsl = _
            "SELECT [Data$.Email], [Data$.Familiya], [Data$.Obrazovaniye], [Data$.Opyt raboty], [Data$.Nachalo], [Data$.Okonchaniye], [Data$.Stbl7], [Data$.Stbl8], [Data$.Id] " & _
            "FROM [Data$], [Zapros$] " & _
            "WHERE [Zapros$.Email] = [Data$.Email];"
            
            With .QueryTables.Add(Connection:=strCon, Destination:=.Range("A1"), Sql:=unvrsl)
                .FieldNames = True
                .PreserveFormatting = True
                .Refresh BackgroundQuery:=False
                .Delete
            End With
            
            'Yesli budut problemy c datoy - znachit yesli budut tekstovye dannye v stolbtsakh
            'With .Range("E2:F" & .Cells(.Rows.Count, "E").End(xlUp).Row)
            '    .NumberFormat = "dd/mm/yyyy"
            '    unvrsl = .Value: .Value = unvrsl: unvrsl = Empty
            'End With
            
            .Range("A1").CurrentRegion.EntireColumn.AutoFit
        End With
    End With
    Application.ScreenUpdating = True
End Sub
 
 
 
#7
29.12.2019 16:32:50
ocet p,  Если появляется макрос, то через ADODB все сразу сделать и просто рекордсэт вывести. А если Query, то оно раз созданное будет работать, разве что путь к файлу прописать для автоматизации.
По вопросам из тем форума, личку не читаю.
 
 
 
#8
29.12.2019 19:00:38
:) ... каждому что нравится и к чему привык ...  :)  ... только чтобы был выбор
 
 
 
Страницы: 1
Наверх