Домашняя страница Undo Do New Save Карта сайта Обратная связь Поиск по форуму
МИР MS EXCEL - Гость.xls

Вход

Регистрация

Напомнить пароль

 

= Мир MS Excel/Автоматически разбить файл excel на несколько по условию - Мир MS Excel

Регистрация · Логин: · Пароль: · · Забыли пароль?
  • Страница 1 из 1
  • 1
Модератор форума: _Boroda_, Manyasha, SLAVICK, китин  
Мир MS Excel » Вопросы и решения » Вопросы по VBA » Автоматически разбить файл excel на несколько по условию (Макросы/Sub)
Автоматически разбить файл excel на несколько по условию
evgen7e Дата: Воскресенье, 07.07.2019, 19:58 | Сообщение № 1
Группа: Пользователи
Ранг: Прохожий
Сообщений: 1
Репутация: 0 ±
Замечаний: 0% ±

Excel 2007
Всем доброго времени суток!

Имеется файл с большим количеством строк такого типа:


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

Имеется файл с большим количеством строк такого типа:


Требуется разбить файл на несколько по первому столбцу (для каждого филиала свой файлик).
С VBA сталкиваюсь впервые, подскажите, пожалуйста, с чего начать, куда копать..
Возможно у кого-то уже есть что-то либо подобное.
Буду очень благодарен за помощь!

Автор - evgen7e
Дата добавления - 07.07.2019 в 19:58
nilem Дата: Понедельник, 08.07.2019, 06:35 | Сообщение № 2
Группа: Авторы
Ранг: Старожил
Сообщений: 1541
Репутация: 532 ±
Замечаний: 0% ±

Excel 2013
evgen7e, привет
посмотрите вот здесь, в файле-примере есть как раз Ваш вариант


Яндекс.Деньги 4100159601573
 
Ответить
Сообщениеevgen7e, привет
посмотрите вот здесь, в файле-примере есть как раз Ваш вариант

Автор - nilem
Дата добавления - 08.07.2019 в 06:35
skais Дата: Понедельник, 08.07.2019, 11:28 | Сообщение № 3
Группа: Проверенные
Ранг: Форумчанин
Сообщений: 186
Репутация: 25 ±
Замечаний: 60% ±

Excel 2010
Что-то подобное:
[vba]
Код
Sub Путь_к_файлу()
    Dim FilesToOpen
    Dim OpenPath As String
    OpenPath = CStr(ThisWorkbook.Path)
    'ChDrive "C:\Program Files"
    ChDrive OpenPath
    ChDir OpenPath
    FilesToOpen = Application.GetOpenFilename _
        ("Excel files(*.xls*),*.xls*", 1, "Выбрать файл", , False)
    If TypeName(FilesToOpen) = "Boolean" Then
        MsgBox "Файл не выбран!"
        Exit Sub
    End If
    Cells(2, "D") = FilesToOpen
End Sub
Sub Получить()
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    Application.Calculation = xlCalculationManual
    Dim Dict As Object
    Dim Links As Variant
    Set Dict = CreateObject("scripting.dictionary"): Dict.comparemode = 1
   
    With Sheets("Лимиты")
        lr = .Cells(.Rows.Count, "K").End(xlUp).Row
        If lr > 1 Then
            For i = 2 To lr
                If Not Dict.exists(.Cells(i, "K").Value) And .Cells(i, "K").Value <> "" Then Dict.Add (.Cells(i, "K").Value), 1
            Next
        End If
    End With
    n = 0
    For Each vkey In Dict.Keys
        n = n + 1
        Application.StatusBar = CStr(n) + " " + vkey
        'Создаем файлы
        Set new_wb = Workbooks.Add
        
        ThisWorkbook.Sheets("Лимиты").Copy Before:=Sheets(1)
        Sheets(1).Visible = True
        
        lr = Cells(Rows.Count, "K").End(xlUp).Row
        For i = lr To 2 Step -1
            If Cells(i, "K") <> vkey Then Rows(i).Delete
        Next
        Sheets(1).Columns("K").Delete
        ActiveSheet.UsedRange.Value = ActiveSheet.UsedRange.Value
        
        new_wb.SaveAs ThisWorkbook.Path + "\" + vkey + ".xlsx"
        new_wb.Close
    Next
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
    MsgBox "Отчёты успешно созданы!", vbInformation, "Информация"
End Sub

[/vba]


Сообщение отредактировал skais - Понедельник, 08.07.2019, 11:30
 
Ответить
СообщениеЧто-то подобное:
[vba]
Код
Sub Путь_к_файлу()
    Dim FilesToOpen
    Dim OpenPath As String
    OpenPath = CStr(ThisWorkbook.Path)
    'ChDrive "C:\Program Files"
    ChDrive OpenPath
    ChDir OpenPath
    FilesToOpen = Application.GetOpenFilename _
        ("Excel files(*.xls*),*.xls*", 1, "Выбрать файл", , False)
    If TypeName(FilesToOpen) = "Boolean" Then
        MsgBox "Файл не выбран!"
        Exit Sub
    End If
    Cells(2, "D") = FilesToOpen
End Sub
Sub Получить()
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    Application.Calculation = xlCalculationManual
    Dim Dict As Object
    Dim Links As Variant
    Set Dict = CreateObject("scripting.dictionary"): Dict.comparemode = 1
   
    With Sheets("Лимиты")
        lr = .Cells(.Rows.Count, "K").End(xlUp).Row
        If lr > 1 Then
            For i = 2 To lr
                If Not Dict.exists(.Cells(i, "K").Value) And .Cells(i, "K").Value <> "" Then Dict.Add (.Cells(i, "K").Value), 1
            Next
        End If
    End With
    n = 0
    For Each vkey In Dict.Keys
        n = n + 1
        Application.StatusBar = CStr(n) + " " + vkey
        'Создаем файлы
        Set new_wb = Workbooks.Add
        
        ThisWorkbook.Sheets("Лимиты").Copy Before:=Sheets(1)
        Sheets(1).Visible = True
        
        lr = Cells(Rows.Count, "K").End(xlUp).Row
        For i = lr To 2 Step -1
            If Cells(i, "K") <> vkey Then Rows(i).Delete
        Next
        Sheets(1).Columns("K").Delete
        ActiveSheet.UsedRange.Value = ActiveSheet.UsedRange.Value
        
        new_wb.SaveAs ThisWorkbook.Path + "\" + vkey + ".xlsx"
        new_wb.Close
    Next
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
    MsgBox "Отчёты успешно созданы!", vbInformation, "Информация"
End Sub

[/vba]

Автор - skais
Дата добавления - 08.07.2019 в 11:28
Мир MS Excel » Вопросы и решения » Вопросы по VBA » Автоматически разбить файл excel на несколько по условию (Макросы/Sub)
  • Страница 1 из 1
  • 1
Поиск:

Яндекс цитирования
© 2010-2019 · Дизайн: MichaelCH · Хостинг от uCoz · При использовании материалов сайта, ссылка на www.excelworld.ru обязательна!