Страницы: 1
RSS
Макрос копирование данных по условиям в новые книги и сохранение с нужным именем
 
Добрый день!

Надеюсь на вашу помощь, сама никак не могу написать нужный макрос.
Дано:
Список с разными данными в листе "List1".

Надо:
1) Скопировать данные из "List1", начиная с колонки "Имя" (она не всегда начинается с четвертой колонки, может и со второй и с третьей  и.д.) и до последней существующей колонки (в данном примере скопировать значения с колонок от D1 до I36) в новые excel файлы.
Но надо скопировать только данные по тем фирмам, которые указанны в листе "Settings" - Фирма А и Фирма Б
2) в получившихся excel удалить колонки "ID" и "скидка"
3) присвоить название новым книгам excel, как указано в листе "Settings" напротив каждой соответствующей фирмы.
 
Добрый день. А что конкретно у вас не получается? А то в файле примере никаких намеков на попытки написать процедуру... :)
Кому решение нужно - тот пример и рисует.
 
Цитата
5nica написал:
никак не могу написать нужный макрос
а какой макрос у Вас получается?
Неизлечимых болезней нет, есть неизлечимые люди.
 
Все свои неудачные попытки удалила. К тому же навыков не хватает - я скорее занимаюсь "собирательством" похожих макросов в интернете и переделываю под свои нужды, но по всем описанным критериям ничего путного не смогла найти.


Вот мои примитивные недоработки:
Код
Sub do_excel()

Dim MeaName, folderName
Dim New_Wb As Workbook
MeaName = Worksheets("Settings").Range("B2").Value & ".xlsx"
folderName = ThisWorkbook.Path & "\" & MeaName

    Range("D:I").Select
  
    Selection.Copy
    Set New_Wb = Workbooks.Add
    New_Wb.Activate
    Range("A1").Select

    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
        SkipBlanks:=False, Transpose:=False
    Range("A1").Select
    Selection.EntireColumn.AutoFit
    Range("A1").Select
       
    New_Wb.SaveAs folderName
    New_Wb.Close

End Sub
 
Сохраняет в папку с основной книгой.
Код
Option Explicit

Sub test()
    Dim arr(), ikey, book As Workbook
    Dim coll As New Collection, i&
    Dim dic As Object, cnct$, iselect$
    Dim iConnection As Object
    Dim iRecordset As Object
    
    With Application
        .DisplayAlerts = False
        .ScreenUpdating = False
    End With
        Set iConnection = CreateObject("ADODB.Connection")
    Set iRecordset = CreateObject("ADODB.Recordset")
    With Worksheets("Settings")
        arr = .Range(.[a2], .[a1].End(xlDown)).Value
    End With
    On Error Resume Next
    For Each ikey In arr
        coll.Add ikey, CStr(ikey)
    Next ikey
    On Error GoTo 0
    
    cnct = "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & _
        ThisWorkbook.Path & "\" & ThisWorkbook.Name
    cnct = cnct & ";Extended Properties='Excel 12.0;HDR=YES';"
    iConnection.ConnectionString = cnct
    
    For Each ikey In coll
        iConnection.Open
        iselect = "Select * From [List1$] Where Фирма = '" & ikey & "'"
        With iRecordset
            .Open iselect, iConnection
            Set book = Workbooks.Add(1)
            book.SaveAs ThisWorkbook.Path & "\" & ikey & ".xlsx"
            For i = 1 To .Fields.Count
                book.Sheets(1).Cells(1, i).Value = .Fields(i - 1).Name
            Next i
            book.Sheets(1).[a2].CopyFromRecordset iRecordset
        End With
        iConnection.Close
        With book.Worksheets(1)
            .Columns.AutoFit
            '.[a1].CurrentRegion.Borders.LineStyle = xlContinuous
            .Parent.Close True
        End With
    Next ikey
        
    With Application
        .DisplayAlerts = True
        .ScreenUpdating = True
    End With
End Sub
"Все гениальное просто, а все простое гениально!!!"
 
Можно на словарях и массивах сделать, времени пока нет.
"Все гениальное просто, а все простое гениально!!!"
 
ого, думала гораздо короче и проще будет..  буду разбирать
Спасибо!
 
Код
Sub do_excel()
Dim folderName As String, Rng As Range
Dim New_Wb As Workbook
folderName = ThisWorkbook.Path & "\" & Worksheets("Settings").Range("B2").Value & ".xlsx"
For Each Rng In Worksheets("Settings").Range("A2:A" & Worksheets("Settings").Cells(Worksheets("Settings").Rows.Count, 1).End(xlUp).Row)
    With ActiveSheet
        If .AutoFilterMode Then .AutoFilterMode = False
        With .Range("A1").CurrentRegion
            .AutoFilter Field:=3, Operator:=xlFilterValues, Criteria1:=Rng.Value 'столбец Фирма - 3
            .SpecialCells(xlCellTypeVisible).Copy
        End With
    End With
    Set New_Wb = Workbooks.Add
    Range("A1").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
    Range("A1").PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
    Range("A1").EntireColumn.AutoFit
    Columns("A:C").Delete Shift:=xlLeft 'удаляем 3 первых столбца
    New_Wb.SaveAs folderName
    New_Wb.Close
Next Rng
If ActiveSheet.AutoFilterMode Then ActiveSheet.AutoFilterMode = False
End Sub
с помощью автофильтра
Неизлечимых болезней нет, есть неизлечимые люди.
 
Цитата
TheBestOfTheBest
Этот мне понятнее, но к сожалению не работает как надо и не соблюдаются все описанные критерии, а жаль).
С автофильтром хорошая идея, надо будет попробовать
 
А тот что непонятен работает?
"Все гениальное просто, а все простое гениально!!!"
 
Цитата
5nica написал:
не соблюдаются все описанные критерии
А никто и не пытался выполнить Ваше ТЗ, это идея и примерный код, остальное - допиливать.
Неизлечимых болезней нет, есть неизлечимые люди.
 
Цитата
Nordheim А тот что непонятен работает?
боюсь запускать не известные макросы, там много нового для меня. Сначала буду изучать из чего состоит))

Цитата
TheBestOfTheBest написал:
А никто и не пытался выполнить Ваше ТЗ
не прошу выполнить, хоть дать варианты) за вариант с автофильтром спасибо
Изменено: 5nica - 27.03.2018 23:37:56
 
Цитата
5nica написал:
боюсь запускать не известные макросы, там много нового для меня. Сначала буду изучать из чего состоит))
Создайте новую папку, сохраните в нее копию файла с макросом и пробуйте.
"Все гениальное просто, а все простое гениально!!!"
 
Nordheim, макрос работает, только не удаляются нужные колонки и не применяется нужное название файла, а это я сама смогу поправить))
Интересно, что макрос переименовывает в новых книгах шапку второй колонки в "другие данные1", т.к. видимо ему не нравятся колонки с одинаковыми именами.
Спасибо большое!
 
Удаляет и сохраняет как нужно!
Код
Sub test()
    Dim arr(), ikey, book As Workbook
    Dim coll As New Collection, i&
    Dim cnct$, iselect$, iClmnName$
    Dim iConnection As Object
    Dim iRecordset As Object
  
  With Application
        .DisplayAlerts = False
        .ScreenUpdating = False
    End With
'    Set iConnection = CreateObject("ADODB.Connection")
'    Set iRecordset = CreateObject("ADODB.Recordset")
    With Worksheets("Settings")
        arr = .Range(.[a2], .[a1].End(xlDown)).Value
    End With
    On Error Resume Next
    For Each ikey In arr
        coll.Add ikey, CStr(ikey)
    Next ikey
    On Error GoTo 0
    With Worksheets("List1")
        For i = 1 To .Cells(1, .Columns.Count).End(xlToLeft).Column
            If .Cells(1, i) <> "ID" And .Cells(1, i) <> "ñêèäêà" Then iClmnName = iClmnName & "[" & .Cells(1, i) & "],"
        Next i
        iClmnName = Left(iClmnName, Len(iClmnName) - 1)
    End With
     
    cnct = "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & _
        ThisWorkbook.Path & "\" & ThisWorkbook.Name
    cnct = cnct & ";Extended Properties='Excel 12.0;HDR=YES';"
    iConnection.ConnectionString = cnct
    For Each ikey In coll
        iConnection.Open
        iselect = "Select " & iClmnName & " From [List1$] Where Ôèðìà = '" & ikey & "'"
        With iRecordset
            .Open iselect, iConnection
            Set book = Workbooks.Add(1)
            book.SaveAs ThisWorkbook.Path & "\" & ikey & "_" & Date & ".xlsx"
            For i = 1 To .Fields.Count
                book.Sheets(1).Cells(1, i).Value = .Fields(i - 1).Name
            Next i
            book.Sheets(1).[a2].CopyFromRecordset iRecordset
        End With
        iConnection.Close
        With book.Worksheets(1)
            .Columns.AutoFit
            .Parent.Close True
        End With
    Next ikey
         
    With Application
        .DisplayAlerts = True
        .ScreenUpdating = True
    End With
End Sub
"Все гениальное просто, а все простое гениально!!!"
 
Цитата
Nordheim написал:
Удаляет и сохраняет как нужно!
Не идет у меня что то.
Сначала убрала запятые вот в этом месте, чтобы не как коммент было:
Цитата
Nordheim написал:
'    Set iConnection = CreateObject("ADODB.Connection")
'    Set iRecordset = CreateObject("ADODB.Recordset")
Потом у меня русский ексель не идет, заменила слова "Фирма" на "Firma" и "Скидка" на "Skidka" - тоже дальше смогла продвинуться.

Застревает на этом месте:
book.SaveAs ThisWorkbook.Path & "\" & ikey & "_" & Date & ".xlsx"
 
Аааа, ну конечно! У меня формат даты на компьютере dd/mm/yyyy, а этот символ "/" запрещен для наименования.
Все работает, спасибо!
Страницы: 1
Наверх