Помогите написать макрос, который разделит файл 5086469.XLSX на столько файлов, сколько значений в столбце "Район" (на 8 файлов) с именем каждого по названию района (н-р Агинский.xlsx, Акшинский.xlsx и т.д.). Заранее спасибо!
Помогите написать макрос, который разделит файл 5086469.XLSX на столько файлов, сколько значений в столбце "Район" (на 8 файлов) с именем каждого по названию района (н-р Агинский.xlsx, Акшинский.xlsx и т.д.). Заранее спасибо!GeorgeXIII
GeorgeXIII, в Вашем случае, если так и будет отсортирован по району файл, то можно так: [vba]
Код
Sub Разделение() Dim i&, i_n&, k&, k2& Dim WB As Workbook, TWB As Workbook Dim path1$ Dim o As Object, key$, pthkey$ Set TWB = ThisWorkbook path1 = TWB.Path & "\" Application.ScreenUpdating = False Application.DisplayAlerts = False i_n = TWB.Worksheets(1).Cells(Rows.Count, 2).End(xlUp).Row Set o = CreateObject("Scripting.dictionary") For i = 2 To i_n key = TWB.Worksheets(1).Cells(i, 2) If Not o.exists(key) Then k = k + 1 If k > 1 Then WB.SaveAs Filename:=path1 & pthkey & ".xlsx" WB.Close End If Set WB = Workbooks.Add TWB.Worksheets(1).Rows(1).Copy WB.Worksheets(1).Cells(1, 1).PasteSpecial Paste:=xlPasteColumnWidths TWB.Worksheets(1).Rows(1).Copy WB.Worksheets(1).Cells(1, 1).PasteSpecial Paste:=xlPasteAll WB.Worksheets(1).Cells(1, 1).Resize(, 7).AutoFilter o.Add key, k pthkey = key k2 = 1 End If k2 = k2 + 1 TWB.Worksheets(1).Rows(i).Copy WB.Worksheets(1).Cells(k2, 1) Next i WB.SaveAs Filename:=path1 & pthkey & ".xlsx" Application.DisplayAlerts = True Application.ScreenUpdating = True End Sub
[/vba]
GeorgeXIII, в Вашем случае, если так и будет отсортирован по району файл, то можно так: [vba]
Код
Sub Разделение() Dim i&, i_n&, k&, k2& Dim WB As Workbook, TWB As Workbook Dim path1$ Dim o As Object, key$, pthkey$ Set TWB = ThisWorkbook path1 = TWB.Path & "\" Application.ScreenUpdating = False Application.DisplayAlerts = False i_n = TWB.Worksheets(1).Cells(Rows.Count, 2).End(xlUp).Row Set o = CreateObject("Scripting.dictionary") For i = 2 To i_n key = TWB.Worksheets(1).Cells(i, 2) If Not o.exists(key) Then k = k + 1 If k > 1 Then WB.SaveAs Filename:=path1 & pthkey & ".xlsx" WB.Close End If Set WB = Workbooks.Add TWB.Worksheets(1).Rows(1).Copy WB.Worksheets(1).Cells(1, 1).PasteSpecial Paste:=xlPasteColumnWidths TWB.Worksheets(1).Rows(1).Copy WB.Worksheets(1).Cells(1, 1).PasteSpecial Paste:=xlPasteAll WB.Worksheets(1).Cells(1, 1).Resize(, 7).AutoFilter o.Add key, k pthkey = key k2 = 1 End If k2 = k2 + 1 TWB.Worksheets(1).Rows(i).Copy WB.Worksheets(1).Cells(k2, 1) Next i WB.SaveAs Filename:=path1 & pthkey & ".xlsx" Application.DisplayAlerts = True Application.ScreenUpdating = True End Sub
Sub d() Dim sh As Worksheet, rng As Range ActiveSheet.Copy With ActiveWorkbook Set sh = .Sheets(1) On Error Resume Next Do Until Err Set rng = sh.[b2].Resize(sh.Rows.Count - 1).ColumnDifferences(sh.[b2]) If Err = 0 Then Sheets.Add , sh sh.[1:1].Copy sh.Next.[1:1]: rng.EntireRow.Cut sh.Next.[A2] sh.[1:1].Copy: sh.Next.[1:1].PasteSpecial (xlPasteColumnWidths) sh.SaveAs "D:\папка\" & sh.[b2] & ".xlsx": Set sh = sh.Next Loop .Close False End With End Sub
[/vba]
еще вариант [vba]
Код
Sub d() Dim sh As Worksheet, rng As Range ActiveSheet.Copy With ActiveWorkbook Set sh = .Sheets(1) On Error Resume Next Do Until Err Set rng = sh.[b2].Resize(sh.Rows.Count - 1).ColumnDifferences(sh.[b2]) If Err = 0 Then Sheets.Add , sh sh.[1:1].Copy sh.Next.[1:1]: rng.EntireRow.Cut sh.Next.[A2] sh.[1:1].Copy: sh.Next.[1:1].PasteSpecial (xlPasteColumnWidths) sh.SaveAs "D:\папка\" & sh.[b2] & ".xlsx": Set sh = sh.Next Loop .Close False End With End Sub
Чуть изменил, чтобы подправлять в 1 месте можно было: [vba]
Код
Sub Разделение() Dim i&, i_n&, k&, k2& Dim WB As Workbook, TWB As Workbook Dim path1$ Dim o As Object, key$, pthkey$ Dim ft$ ft = ".xls" Set TWB = ThisWorkbook path1 = TWB.Path & "\" Application.ScreenUpdating = False Application.DisplayAlerts = False i_n = TWB.Worksheets(1).Cells(Rows.Count, 2).End(xlUp).Row Set o = CreateObject("Scripting.dictionary") For i = 2 To i_n key = TWB.Worksheets(1).Cells(i, 2) If Not o.exists(key) Then k = k + 1 If k > 1 Then WB.SaveAs Filename:=path1 & pthkey & ft WB.Close End If Set WB = Workbooks.Add TWB.Worksheets(1).Rows(1).Copy WB.Worksheets(1).Cells(1, 1).PasteSpecial Paste:=xlPasteColumnWidths TWB.Worksheets(1).Rows(1).Copy WB.Worksheets(1).Cells(1, 1).PasteSpecial Paste:=xlPasteAll WB.Worksheets(1).Cells(1, 1).Resize(, 7).AutoFilter o.Add key, k pthkey = key k2 = 1 End If k2 = k2 + 1 TWB.Worksheets(1).Rows(i).Copy WB.Worksheets(1).Cells(k2, 1) Next i WB.SaveAs Filename:=path1 & pthkey & ft Application.DisplayAlerts = True Application.ScreenUpdating = True End Sub
[/vba] Подправить расширение файла можно в строчке [vba]
Код
ft = ".xls"
[/vba]
Гораздо красивее и интереснее вариант krosav4ig. Он и заметно быстрее обрабатывать будет на больших таблицах.
Чуть изменил, чтобы подправлять в 1 месте можно было: [vba]
Код
Sub Разделение() Dim i&, i_n&, k&, k2& Dim WB As Workbook, TWB As Workbook Dim path1$ Dim o As Object, key$, pthkey$ Dim ft$ ft = ".xls" Set TWB = ThisWorkbook path1 = TWB.Path & "\" Application.ScreenUpdating = False Application.DisplayAlerts = False i_n = TWB.Worksheets(1).Cells(Rows.Count, 2).End(xlUp).Row Set o = CreateObject("Scripting.dictionary") For i = 2 To i_n key = TWB.Worksheets(1).Cells(i, 2) If Not o.exists(key) Then k = k + 1 If k > 1 Then WB.SaveAs Filename:=path1 & pthkey & ft WB.Close End If Set WB = Workbooks.Add TWB.Worksheets(1).Rows(1).Copy WB.Worksheets(1).Cells(1, 1).PasteSpecial Paste:=xlPasteColumnWidths TWB.Worksheets(1).Rows(1).Copy WB.Worksheets(1).Cells(1, 1).PasteSpecial Paste:=xlPasteAll WB.Worksheets(1).Cells(1, 1).Resize(, 7).AutoFilter o.Add key, k pthkey = key k2 = 1 End If k2 = k2 + 1 TWB.Worksheets(1).Rows(i).Copy WB.Worksheets(1).Cells(k2, 1) Next i WB.SaveAs Filename:=path1 & pthkey & ft Application.DisplayAlerts = True Application.ScreenUpdating = True End Sub
[/vba] Подправить расширение файла можно в строчке [vba]
Код
ft = ".xls"
[/vba]
Гораздо красивее и интереснее вариант krosav4ig. Он и заметно быстрее обрабатывать будет на больших таблицах.Roman777
Много чего не знаю!!!!
Сообщение отредактировал Roman777 - Воскресенье, 05.03.2017, 09:59