Нужно таблицу разгруппировать по разным файлам. - Microsoft Office Excel

Dimitriusik · 02.06.2017, 11:13

Добрый день! Столкнулся со следующей проблемой
Есть следующая таблица. Данные в столбце А повторяются. Надо разгруппировать данные из этого столбца в разные файлы в каталог С:/Reports/.
Например из данного файла чтоб получилось три файла ГИМНАЗИЯ №1 (с 6 соответствующими записями), ГИМНАЗИЯ №4 (с соответствующими 2 записями), и СОШ №43 (с ему соответсвующими записями). Шапку оставить нужно такой же.
Это случайный список. На деле учебных заведений более 200 и учащихся более 50 000.

Книга11.xls

Aleksandr H. · 02.06.2017, 11:22

А с чем проблема или "помогите плииз" = "сделайте мне готовое"?

Dimitriusik · 02.06.2017, 11:33

Цитата:

Сообщение от Aleksandr H.

А с чем проблема или "помогите плииз" = "сделайте мне готовое"?

у меня даже идей нет как теперь это сделать

Aleksandr H. · 02.06.2017, 11:55

Вот идея. Столбец А от 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 · 02.06.2017, 12:11

Цитата:

Сообщение от 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

Цитата:

Сообщение от 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

почему-то из каждой таблицы последнюю строку обрезает.. как бы это исправить?

Aleksandr H. · 05.06.2017, 20:17

пробуйте

Код:

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, 20:25

Цитата:

Сообщение от 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. · 05.06.2017, 21:09

Так хотели ведь идею! Пилите, Шура, под себя.

Код:

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 · 05.06.2017, 21:27

Цитата:

Сообщение от 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

ПЕРВЫЙ ПОДОШЕЛ! СПАСИБО БОЛЬШУЩЕЕ!))

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

02.06.2017, 11:22	#2
Aleksandr H. 2 the Nation Glory Старожил Регистрация: 27.05.2014 Сообщений: 3,289	А с чем проблема или "помогите плииз" = "сделайте мне готовое"? Кто умер, но не забыт, тот бессмертен. Лао-Цзы.

Похожие темы
Тема	Автор	Раздел	Ответов	Последнее сообщение
Нужно добавить запись в таблицу	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