Форум программистов
 

Восстановите пароль или Зарегистрируйтесь на форуме, о проблемах и с заказом рекламы пишите сюда - alarforum@yandex.ru, проверяйте папку спам!

Вернуться   Форум программистов > Microsoft Office и VBA программирование > Microsoft Office Excel
Регистрация

Восстановить пароль
Повторная активизация e-mail

Купить рекламу на форуме - 42 тыс руб за месяц

Ответ
 
Опции темы Поиск в этой теме
Старый 02.06.2017, 11:13   #1
Dimitriusik
Пользователь
 
Регистрация: 02.06.2017
Сообщений: 29
По умолчанию Нужно таблицу разгруппировать по разным файлам.

Добрый день! Столкнулся со следующей проблемой
Есть следующая таблица. Данные в столбце А повторяются. Надо разгруппировать данные из этого столбца в разные файлы в каталог С:/Reports/.
Например из данного файла чтоб получилось три файла ГИМНАЗИЯ №1 (с 6 соответствующими записями), ГИМНАЗИЯ №4 (с соответствующими 2 записями), и СОШ №43 (с ему соответсвующими записями). Шапку оставить нужно такой же.
Это случайный список. На деле учебных заведений более 200 и учащихся более 50 000.
Книга11.xls
Dimitriusik вне форума Ответить с цитированием
Старый 02.06.2017, 11:22   #2
Aleksandr H.
2 the Nation Glory
Старожил
 
Аватар для Aleksandr H.
 
Регистрация: 27.05.2014
Сообщений: 3,289
По умолчанию

А с чем проблема или "помогите плииз" = "сделайте мне готовое"?
Кто умер, но не забыт, тот бессмертен.
Лао-Цзы.
Aleksandr H. вне форума Ответить с цитированием
Старый 02.06.2017, 11:33   #3
Dimitriusik
Пользователь
 
Регистрация: 02.06.2017
Сообщений: 29
По умолчанию

Цитата:
Сообщение от Aleksandr H. Посмотреть сообщение
А с чем проблема или "помогите плииз" = "сделайте мне готовое"?
у меня даже идей нет как теперь это сделать
Dimitriusik вне форума Ответить с цитированием
Старый 02.06.2017, 11:55   #4
Aleksandr H.
2 the Nation Glory
Старожил
 
Аватар для Aleksandr H.
 
Регистрация: 27.05.2014
Сообщений: 3,289
По умолчанию

Вот идея. Столбец А от 4 и до последней строки должны быть отсортированы
Код:
Sub a()
    Dim rng As Range
    Dim r As Long
    Dim school As String
    Dim wb As Workbook
    r = 3
    Do While Sheets(1).Cells(r, 1) <> ""
        If Sheets(1).Cells(r, 1) <> Sheets(1).Cells(r + 1, 1) Then
            school = Sheets(1).Cells(r, 1)
            rng.Copy
            Set wb = Workbooks.Add
            wb.Sheets(1).Range("A1").PasteSpecial (xlPasteValues)
            wb.SaveAs Filename:="C:\Raports\" & school & ".xlsx"
            Application.CutCopyMode = False
            wb.Close
            Set wb = Nothing
            Set rng = Nothing
        End If
        If rng Is Nothing Then
            Set rng = Sheets(1).Range("A1:E2")
        Else
            Set rng = Union(rng, Sheets(1).Range("A" & r & ":E" & r))
        End If
        r = r + 1
    Loop
End Sub
Кто умер, но не забыт, тот бессмертен.
Лао-Цзы.
Aleksandr H. вне форума Ответить с цитированием
Старый 02.06.2017, 12:11   #5
Dimitriusik
Пользователь
 
Регистрация: 02.06.2017
Сообщений: 29
По умолчанию

Цитата:
Сообщение от Aleksandr H. Посмотреть сообщение
Вот идея. Столбец А от 4 и до последней строки должны быть отсортированы
Код:
Sub a()
    Dim rng As Range
    Dim r As Long
    Dim school As String
    Dim wb As Workbook
    r = 3
    Do While Sheets(1).Cells(r, 1) <> ""
        If Sheets(1).Cells(r, 1) <> Sheets(1).Cells(r + 1, 1) Then
            school = Sheets(1).Cells(r, 1)
            rng.Copy
            Set wb = Workbooks.Add
            wb.Sheets(1).Range("A1").PasteSpecial (xlPasteValues)
            wb.SaveAs Filename:="C:\Raports\" & school & ".xlsx"
            Application.CutCopyMode = False
            wb.Close
            Set wb = Nothing
            Set rng = Nothing
        End If
        If rng Is Nothing Then
            Set rng = Sheets(1).Range("A1:E2")
        Else
            Set rng = Union(rng, Sheets(1).Range("A" & r & ":E" & r))
        End If
        r = r + 1
    Loop
End Sub
БОЛЬШОЕ СПАСИБО! ВЫРУЧИЛ!
Dimitriusik вне форума Ответить с цитированием
Старый 05.06.2017, 19:10   #6
Dimitriusik
Пользователь
 
Регистрация: 02.06.2017
Сообщений: 29
По умолчанию

Цитата:
Сообщение от Aleksandr H. Посмотреть сообщение
Вот идея. Столбец А от 4 и до последней строки должны быть отсортированы
Код:
Sub a()
    Dim rng As Range
    Dim r As Long
    Dim school As String
    Dim wb As Workbook
    r = 3
    Do While Sheets(1).Cells(r, 1) <> ""
        If Sheets(1).Cells(r, 1) <> Sheets(1).Cells(r + 1, 1) Then
            school = Sheets(1).Cells(r, 1)
            rng.Copy
            Set wb = Workbooks.Add
            wb.Sheets(1).Range("A1").PasteSpecial (xlPasteValues)
            wb.SaveAs Filename:="C:\Raports\" & school & ".xlsx"
            Application.CutCopyMode = False
            wb.Close
            Set wb = Nothing
            Set rng = Nothing
        End If
        If rng Is Nothing Then
            Set rng = Sheets(1).Range("A1:E2")
        Else
            Set rng = Union(rng, Sheets(1).Range("A" & r & ":E" & r))
        End If
        r = r + 1
    Loop
End Sub
почему-то из каждой таблицы последнюю строку обрезает.. как бы это исправить?
Dimitriusik вне форума Ответить с цитированием
Старый 05.06.2017, 20:17   #7
Aleksandr H.
2 the Nation Glory
Старожил
 
Аватар для Aleksandr H.
 
Регистрация: 27.05.2014
Сообщений: 3,289
По умолчанию

пробуйте
Код:
Sub a()
    Dim rng As Range
    Dim r As Long
    Dim school As String
    Dim wb As Workbook
    Dim rCount As Long
    r = 3
    With Sheets(1)
        rCount = .Cells(.Rows.Count, 1).End(xlUp).Row
    End With
    Do While r <= rCount
        If Sheets(1).Cells(r, 1) <> Sheets(1).Cells(r + 1, 1) Then
            school = Sheets(1).Cells(r, 1)
            rng.Copy
            Set wb = Workbooks.Add
            wb.Sheets(1).Range("A1").PasteSpecial (xlPasteValues)
            wb.SaveAs Filename:="C:\Raports\" & school & ".xlsx"
            Application.CutCopyMode = False
            wb.Close
            Set wb = Nothing
            Set rng = Nothing
        End If
        If rng Is Nothing Then
            Set rng = Sheets(1).Range("A1:E2")
        Else
            Set rng = Union(rng, Sheets(1).Range("A" & r & ":E" & r))
        End If
        r = r + 1
    Loop
End Sub
кста, здесь можно и макрос "школа" запускать
Кто умер, но не забыт, тот бессмертен.
Лао-Цзы.
Aleksandr H. вне форума Ответить с цитированием
Старый 05.06.2017, 20:25   #8
Dimitriusik
Пользователь
 
Регистрация: 02.06.2017
Сообщений: 29
По умолчанию

Цитата:
Сообщение от Aleksandr H. Посмотреть сообщение
пробуйте
Код:
Sub a()
    Dim rng As Range
    Dim r As Long
    Dim school As String
    Dim wb As Workbook
    Dim rCount As Long
    r = 3
    With Sheets(1)
        rCount = .Cells(.Rows.Count, 1).End(xlUp).Row
    End With
    Do While r <= rCount
        If Sheets(1).Cells(r, 1) <> Sheets(1).Cells(r + 1, 1) Then
            school = Sheets(1).Cells(r, 1)
            rng.Copy
            Set wb = Workbooks.Add
            wb.Sheets(1).Range("A1").PasteSpecial (xlPasteValues)
            wb.SaveAs Filename:="C:\Raports\" & school & ".xlsx"
            Application.CutCopyMode = False
            wb.Close
            Set wb = Nothing
            Set rng = Nothing
        End If
        If rng Is Nothing Then
            Set rng = Sheets(1).Range("A1:E2")
        Else
            Set rng = Union(rng, Sheets(1).Range("A" & r & ":E" & r))
        End If
        r = r + 1
    Loop
End Sub
кста, здесь можно и макрос "школа" запускать
Опять не хватает одного.. теперь первого из списка))
Dimitriusik вне форума Ответить с цитированием
Старый 05.06.2017, 21:09   #9
Aleksandr H.
2 the Nation Glory
Старожил
 
Аватар для Aleksandr H.
 
Регистрация: 27.05.2014
Сообщений: 3,289
По умолчанию

Так хотели ведь идею! Пилите, Шура, под себя.
Код:
Sub a()
    Dim rng As Range
    Dim r As Long
    Dim school As String
    Dim wb As Workbook
    Dim rCount As Long
    r = 3
    With Sheets(1)
        rCount = .Cells(.Rows.Count, 1).End(xlUp).Row
        Set rng = .Range("A1:E3")
    End With
    
    Do While r <= rCount
        If Sheets(1).Cells(r, 1) <> Sheets(1).Cells(r + 1, 1) Then
            Set rng = Union(rng, Sheets(1).Range("A" & r & ":E" & r))
            school = Sheets(1).Cells(r, 1)
            rng.Copy
            Set wb = Workbooks.Add
            wb.Sheets(1).Range("A1").PasteSpecial (xlPasteValues)
            wb.SaveAs Filename:="C:\Raports\" & school & ".xlsx"
            Application.CutCopyMode = False
            wb.Close
            Set wb = Nothing
            Set rng = Nothing
        End If
        If rng Is Nothing Then
            Set rng = Sheets(1).Range("A1:E2")
        Else
            Set rng = Union(rng, Sheets(1).Range("A" & r & ":E" & r))
        End If
        r = r + 1
    Loop
End Sub
или

Код:

Sub a()
    Dim rng As Range
    Dim r As Long
    Dim school As String
    Dim wb As Workbook
    r = 3
    Do While Sheets(1).Cells(r, 1) <> ""
        If Sheets(1).Cells(r, 1) <> Sheets(1).Cells(r + 1, 1) Then
            Set rng = Union(rng, Sheets(1).Range("A" & r & ":E" & r))
            school = Sheets(1).Cells(r, 1)
            rng.Copy
            Set wb = Workbooks.Add
            wb.Sheets(1).Range("A1").PasteSpecial (xlPasteValues)
            wb.SaveAs Filename:="C:\Raports\" & school & ".xlsx"
            Application.CutCopyMode = False
            wb.Close
            Set wb = Nothing
            Set rng = Nothing
        End If
        If rng Is Nothing Then
            Set rng = Sheets(1).Range("A1:E2")
        Else
            Set rng = Union(rng, Sheets(1).Range("A" & r & ":E" & r))
        End If
        r = r + 1
    Loop
End Sub
Кто умер, но не забыт, тот бессмертен.
Лао-Цзы.
Aleksandr H. вне форума Ответить с цитированием
Старый 05.06.2017, 21:27   #10
Dimitriusik
Пользователь
 
Регистрация: 02.06.2017
Сообщений: 29
По умолчанию

Цитата:
Сообщение от Aleksandr H. Посмотреть сообщение
пробуйте
Код:
Sub a()
    Dim rng As Range
    Dim r As Long
    Dim school As String
    Dim wb As Workbook
    Dim rCount As Long
    r = 3
    With Sheets(1)
        rCount = .Cells(.Rows.Count, 1).End(xlUp).Row
    End With
    Do While r <= rCount
        If Sheets(1).Cells(r, 1) <> Sheets(1).Cells(r + 1, 1) Then
            school = Sheets(1).Cells(r, 1)
            rng.Copy
            Set wb = Workbooks.Add
            wb.Sheets(1).Range("A1").PasteSpecial (xlPasteValues)
            wb.SaveAs Filename:="C:\Raports\" & school & ".xlsx"
            Application.CutCopyMode = False
            wb.Close
            Set wb = Nothing
            Set rng = Nothing
        End If
        If rng Is Nothing Then
            Set rng = Sheets(1).Range("A1:E2")
        Else
            Set rng = Union(rng, Sheets(1).Range("A" & r & ":E" & r))
        End If
        r = r + 1
    Loop
End Sub
кста, здесь можно и макрос "школа" запускать
Цитата:
Сообщение от Aleksandr H. Посмотреть сообщение
Так хотели ведь идею! Пилите, Шура, под себя.
Код:
Sub a()
    Dim rng As Range
    Dim r As Long
    Dim school As String
    Dim wb As Workbook
    Dim rCount As Long
    r = 3
    With Sheets(1)
        rCount = .Cells(.Rows.Count, 1).End(xlUp).Row
        Set rng = .Range("A1:E3")
    End With
    
    Do While r <= rCount
        If Sheets(1).Cells(r, 1) <> Sheets(1).Cells(r + 1, 1) Then
            Set rng = Union(rng, Sheets(1).Range("A" & r & ":E" & r))
            school = Sheets(1).Cells(r, 1)
            rng.Copy
            Set wb = Workbooks.Add
            wb.Sheets(1).Range("A1").PasteSpecial (xlPasteValues)
            wb.SaveAs Filename:="C:\Raports\" & school & ".xlsx"
            Application.CutCopyMode = False
            wb.Close
            Set wb = Nothing
            Set rng = Nothing
        End If
        If rng Is Nothing Then
            Set rng = Sheets(1).Range("A1:E2")
        Else
            Set rng = Union(rng, Sheets(1).Range("A" & r & ":E" & r))
        End If
        r = r + 1
    Loop
End Sub
или

Код:

Sub a()
    Dim rng As Range
    Dim r As Long
    Dim school As String
    Dim wb As Workbook
    r = 3
    Do While Sheets(1).Cells(r, 1) <> ""
        If Sheets(1).Cells(r, 1) <> Sheets(1).Cells(r + 1, 1) Then
            Set rng = Union(rng, Sheets(1).Range("A" & r & ":E" & r))
            school = Sheets(1).Cells(r, 1)
            rng.Copy
            Set wb = Workbooks.Add
            wb.Sheets(1).Range("A1").PasteSpecial (xlPasteValues)
            wb.SaveAs Filename:="C:\Raports\" & school & ".xlsx"
            Application.CutCopyMode = False
            wb.Close
            Set wb = Nothing
            Set rng = Nothing
        End If
        If rng Is Nothing Then
            Set rng = Sheets(1).Range("A1:E2")
        Else
            Set rng = Union(rng, Sheets(1).Range("A" & r & ":E" & r))
        End If
        r = r + 1
    Loop
End Sub
ПЕРВЫЙ ПОДОШЕЛ! СПАСИБО БОЛЬШУЩЕЕ!))
Dimitriusik вне форума Ответить с цитированием
Ответ


Купить рекламу на форуме - 42 тыс руб за месяц

Опции темы Поиск в этой теме
Поиск в этой теме:

Расширенный поиск


Похожие темы
Тема Автор Раздел Ответов Последнее сообщение
Нужно добавить запись в таблицу MaxerrXXX БД в Delphi 3 25.05.2012 19:46
Нужно написать программу по файлам kessi Помощь студентам 0 23.12.2010 16:50
Файл. Раскидать числа по разным файлам ddeman666 Помощь студентам 1 02.06.2010 12:41
Ячейки Ai Bi (лист1) разгруппировать в Ai (лист2) Alexander_Gr Microsoft Office Excel 4 02.12.2007 19:27
Нужно разбить те числа которые в одной ячейке по разным ячейчам в столбец Alexander_Gr Microsoft Office Excel 8 20.11.2007 08:02