Компьютерный форум OSzone.net  

Компьютерный форум OSzone.net (http://forum.oszone.net/index.php)
-   Программирование и базы данных (http://forum.oszone.net/forumdisplay.php?f=21)
-   -   [решено] Разбор листа Excel по строкам в отдельные файлы (http://forum.oszone.net/showthread.php?t=230314)

Debugger 14-03-2012 11:21 1878925

Разбор листа Excel по строкам в отдельные файлы
 
С VBA сталкиваюсь в первый раз, но тут слезно попросили помочь и я согласился. Цель такая - раздербанить Excel-евский файл по строкам в отдельные файлы, причем у каждого файла должна быть шапка (первая строка) из оригинального файла. Примеров скриптов выполняющих такую работу в интернете навалом, но все они выдергивают только по одной строке. Понадергав то тут то там и почитав описания команд наваял примерно такое:
Код:

Sub proga()
Application.ScreenUpdating = False
For i = 2 To Cells.SpecialCells(xlCellTypeLastCell).Row
        Dim r1 As Range, r2 As Range, myMultiAreaRange As Range
        Set r1 = Range(Cells(1, 1), Cells(1, 12))
        Set r2 = Range(Cells(i, 1), Cells(i, 12))
        Set myMultiAreaRange = Union(r1, r2)
        myMultiAreaRange.Select
    Selection.Copy
    Workbooks.Add
    ActiveSheet.Paste
    ActiveWorkbook.SaveAs Filename:= _
        "C:\excel_files\stroka" & i & ".xls", FileFormat:=xlNormal
    ActiveWorkbook.Close
Next
Application.ScreenUpdating = True
End Sub

То есть выдергивается первая строка и вторая, первая и третья, первая и четвертая и так далее. Но в созданную книгу они не копируются, т.е. все созданные файлы сохраняются пустыми. Если выделять только одну строку то все работает. Причем при отладке скрипта видно что в буфер обмена строки попадают, и если переключиться на созданную книгу и нажать Ctrl+V то все вставляется. Гугл уже не помогает, а сроки поджимают.

Iska 14-03-2012 12:58 1879021

Debugger, как-то так:
Код:

Option Explicit

Sub proga()
    Dim i As Long
    Dim objUsedRange As Range
   
   
    Set objUsedRange = ThisWorkbook.ActiveSheet.UsedRange
   
    For i = 2 To objUsedRange.Rows.Count
        With Application.Workbooks.Add
            Union(objUsedRange.Rows(1), objUsedRange.Rows(i)).Copy .ActiveSheet.Cells(1, 1)
           
            .SaveAs "C:\excel_files\stroka" & CStr(i) & ".xls"
            .Close
        End With
    Next
End Sub

Отчего такое странное техзадание?

Debugger 14-03-2012 13:28 1879038

Спасибо, работает. Да черт его знает, человек работает в УЖКХ, таблица это список затрат на каждый дом в городе. Каждый файл по отдельности потом куда-то рассылают. Я не в курсе специфики их работы (и слава богу).

Iska 14-03-2012 15:46 1879110

Debugger, спасибо, ясно. Я себе примерно такое и представлял.


Время: 09:09.

Время: 09:09.
© OSzone.net 2001-