Гость
Войти | Профиль | Очистить
Целевая тема:
Создать новую тему:
Автор:
Действия ...
Форумы / Microsoft Office [игнор отключен] [закрыт для гостей] / Запись определенных листов в определенные файлы согласно условию / 15 сообщений из 15, страница 1 из 1
15.09.2005, 13:47:37
    #33271196
xiao
xiao
Участник
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
Запись определенных листов в определенные файлы согласно условию
Всем, привет! Знаю, что здесь обитают самые умные и отзывчивые программисты планеты, обращаюсь именно к вам, т.к. обращатся с этой проблемой больше не к кому. Есть файл экселевский, состоящий из пары сотни листов. Каждый лист построен одинаково и содержит в ячейке А1 нек. номер. Каждыйй из этих номеров относится к определенному управлению (их 7) нашей конторы. Так вот, мне нужно програмно раскидать эти листы в новые 7 файлов (по кол-ву управлений) согласно номерам содержащимся в ячейках А1. С VBA толком не сталкивалась(только на уровне access, события там всякие на кнопочки писала). Помогите чем можете, пожааалуууйста, нужно срочно!!! Буду оооочень признательна. Кто может пишите на асю 166060777.
...
Рейтинг: 0 / 0
| Ответить | Цитировать | Написать  
15.09.2005, 16:22:02
    #33271714
k-nike
k-nike
Участник
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
Запись определенных листов в определенные файлы согласно условию
Открой редактор вба (Alt+F11). А затем в модуль "Эта книга" вставь эти строчки, заменив соответственно условие1, условие2 и т.д. на 7 своих значений из ячеек A1. И запусти макрос на исполнение F5.
Код: plaintext
1.
2.
3.
4.
5.
6.
7.
8.
9.
10.
11.
12.
13.
14.
15.
16.
17.
18.
19.
20.
21.
22.
23.
24.
25.
26.
27.
28.
29.
30.
31.
32.
33.
Sub process()
    Dim sheet As Worksheet
    Dim book1, book2, book3, book4, book5, book6, book7 As String
    
    Workbooks.Add: book1 = ActiveWorkbook.Name
    Workbooks.Add: book2 = ActiveWorkbook.Name
    Workbooks.Add: book3 = ActiveWorkbook.Name
    Workbooks.Add: book4 = ActiveWorkbook.Name
    Workbooks.Add: book5 = ActiveWorkbook.Name
    Workbooks.Add: book6 = ActiveWorkbook.Name
    Workbooks.Add: book7 = ActiveWorkbook.Name
    ThisWorkbook.Activate
    
    For Each sheet In ThisWorkbook.Sheets
        
        Select Case ThisWorkbook.Sheets(sheet.Name).Range("A1").Value
            Case "условие1"
                sheet.Copy Before:=Workbooks(book1).Sheets( 1 )
            Case "условие2"
                sheet.Copy Before:=Workbooks(book2).Sheets( 1 )
            Case "условие3"
                sheet.Copy Before:=Workbooks(book3).Sheets( 1 )
            Case "условие4"
                sheet.Copy Before:=Workbooks(book4).Sheets( 1 )
            Case "условие5"
                sheet.Copy Before:=Workbooks(book5).Sheets( 1 )
            Case "условие6"
                sheet.Copy Before:=Workbooks(book6).Sheets( 1 )
            Case "условие7"
                sheet.Copy Before:=Workbooks(book7).Sheets( 1 )
        End Select
    Next
    
End Sub
Это все конечно можно короче записать, но я пошел по простому пути.
...
Рейтинг: 0 / 0
| Ответить | Цитировать | Написать  
15.09.2005, 16:51:21
    #33271829
Пользователь2
Пользователь2
Гость
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
Запись определенных листов в определенные файлы согласно условию
Вот набросал. Запускаем из книги с парой сотней листов. Протестировал на книге с пятью листами, вроде нормально.

Код: plaintext
1.
2.
3.
4.
5.
6.
7.
8.
9.
10.
11.
12.
13.
14.
15.
16.
17.
18.
19.
20.
21.
22.
23.
24.
25.
26.
27.
28.
29.
30.
31.
32.
33.
34.
35.
36.
37.
38.
39.
40.
41.
42.
43.
44.
45.
46.
47.
48.
49.
50.
51.
52.
53.
54.
55.
56.
57.
58.
59.
60.
61.
62.
63.
64.
65.
66.
67.
68.
69.
70.
71.
72.
73.
74.
Sub ExtractSheets()
    Dim wb As Workbook
    Dim ws As Worksheet
    Dim rng As Range
    Dim strPath As String
    Dim arr() As Variant
    Dim i As Integer
    Dim j As Integer
    Dim k As Integer
    Dim bln As Boolean
    
    ' Путь, куда копируем новые книги.
    strPath = "d:\1\"
    i =  0 
    
    ' Формируем массив с названиями отделов.
    For Each ws In ThisWorkbook.Worksheets
        bln = False
        Set rng = ws.Range("A1")
        If i =  0  Then
            bln = False
        Else
            For j = LBound(arr) To UBound(arr)
                If arr(j) = rng.Value Then
                    bln = True
                    Exit For
                 End If
            Next j
        End If
        If Not bln Then
            ReDim Preserve arr(i)
            arr(i) = rng.Value
            i = i +  1 
        End If
    Next
    
    ThisWorkbook.Worksheets.Add
    With Application
        .DisplayAlerts = False
        .ScreenUpdating = False
    End With
    
    ' Создаем книги, соответсвующие названию отделов
    ' и переносим листы из существующей книги в новые.
    For k = LBound(arr) To UBound(arr)
        i =  1 
        Set wb = Application.Workbooks.Add
        For Each ws In ThisWorkbook.Worksheets
            Set rng = ws.Range("A1")
            If arr(k) = rng.Value Then
                ws.Move After:=wb.Worksheets(i)
                i = i +  1 
            End If
        Next
        With wb
            ' У меня по умолчанию создается книга с 1 листом,
            ' я его и удаляю.
            .Worksheets( 1 ).Delete
            .SaveAs Filename:=strPath & CStr(arr(k)) & ".xls", _
              FileFormat:=xlNormal
            .Close
        End With
    Next k
    
    Set wb = Nothing
    
    With Application
        .DisplayAlerts = True
        .ScreenUpdating = True
    End With
    
    Application.Quit
    ThisWorkbook.Close SaveChanges:=False
End Sub
...
Рейтинг: 0 / 0
| Ответить | Цитировать | Написать  
16.09.2005, 13:23:37
    #33273464
xiao
xiao
Участник
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
Запись определенных листов в определенные файлы согласно условию
СПАСИБО!! РАБОТАЕТ!!! Второй вариант не пробовала, т.к. первый работает как надо, но обязательно попробую. Единственное, можно ли как-то сразу в программе дать имена новым создающимся файлам?
...
Рейтинг: 0 / 0
| Ответить | Цитировать | Написать  
16.09.2005, 13:43:52
    #33273543
k-nike
k-nike
Участник
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
Запись определенных листов в определенные файлы согласно условию
xiaoСПАСИБО!! РАБОТАЕТ!!! Второй вариант не пробовала, т.к. первый работает как надо, но обязательно попробую. Единственное, можно ли как-то сразу в программе дать имена новым создающимся файлам?
Попробуй второй вариант
...
Рейтинг: 0 / 0
| Ответить | Цитировать | Написать  
19.09.2005, 13:26:59
    #33276535
xiao
xiao
Участник
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
Запись определенных листов в определенные файлы согласно условию
Пользователь2
Код: plaintext
1.
2.
3.
4.
5.
6.
7.
8.
9.
10.
11.
12.
13.
14.
15.
16.
17.
18.
19.
20.
21.
22.
23.
...   
       
    ' Формируем массив с названиями отделов.
    For Each ws In ThisWorkbook.Worksheets
        bln = False
        Set rng = ws.Range("A1")
        If i =  0  Then
            bln = False
        Else
            For j = LBound(arr) To UBound(arr)
                If arr(j) = rng.Value Then
                    bln = True
                    Exit For
                 End If
            Next j
        End If
        If Not bln Then
            ReDim Preserve arr(i)
            arr(i) = rng.Value
            i = i +  1 
        End If
    Next
    
    ...


не понимаю этот кусок. Откуда программа должна брать названия отделов?
что-то мне видимо рано еще писать что-то подобное.:(А сидеть и разбираться что там почем времени нету.
Да и все остальное как-то смутно..
А вот с case все просто и понятно. Я просто подставила в условия нужные номера для определенных файлов и программа раскидала листы по разным файлам без проблем. Только вот назвать бы эти файлы еще там же в программе и было бы совсем чудненько.
...
Рейтинг: 0 / 0
| Ответить | Цитировать | Написать  
19.09.2005, 13:30:41
    #33276547
xiao
xiao
Участник
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
Запись определенных листов в определенные файлы согласно условию
Да и еще хотела спросить, как переименовать все эти листы на значения в ячейках A1?
...
Рейтинг: 0 / 0
| Ответить | Цитировать | Написать  
19.09.2005, 14:24:55
    #33276715
Пользователь2
Пользователь2
Гость
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
Запись определенных листов в определенные файлы согласно условию
Кусок проходит по всем листам и считывает значения, находящиеся в ячейке А1. Исходя из этого формируется массив с названиями отделов.
...
Рейтинг: 0 / 0
| Ответить | Цитировать | Написать  
19.09.2005, 14:29:01
    #33276728
k-nike
k-nike
Участник
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
Запись определенных листов в определенные файлы согласно условию
Как я понял этот код:
xiao Пользователь2
Код: plaintext
1.
2.
3.
4.
5.
...   
       
        Set rng = ws.Range("A1") 'Здесь задается ячейка с названиями отделов
...
        arr(i) = rng.Value 'А здесь в массив записывается значение этой ячейки
    ...


не понимаю этот кусок. Откуда программа должна брать названия отделов?
что-то мне видимо рано еще писать что-то подобное.:(А сидеть и разбираться что там почем времени нету.
Да и все остальное как-то смутно..
А вот с case все просто и понятно. Я просто подставила в условия нужные номера для определенных файлов и программа раскидала листы по разным файлам без проблем. Только вот назвать бы эти файлы еще там же в программе и было бы совсем чудненько.
Иными словами, тебе даже и не надо вводить названия отделов - они сами "введутся".

А по поводу переименования: в этом примере файлы автоматически создаются и сохраняются под именами отделов в папке d:\1\ (меняется переменной strPath)

Ты хоть пробовала его запускать-то?
...
Рейтинг: 0 / 0
| Ответить | Цитировать | Написать  
19.09.2005, 15:02:04
    #33276840
xiao
xiao
Участник
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
Запись определенных листов в определенные файлы согласно условию
k-nikeКак я понял этот код:
Пользователь2
Код: plaintext
1.
2.
3.
4.
5.
...   
      
        Set rng = ws.Range("A1") 'Здесь задается ячейка с названиями отделов
...
        arr(i) = rng.Value 'А здесь в массив записывается значение этой ячейки
    ...


Иными словами, тебе даже и не надо вводить названия отделов - они сами "введутся".
Дело в том, что я же писала выше, что сам этот файл состоящий из 200 листов, не содержит никакой информации относительно отделов, А1 - это просто номер, номера все разные. Поэтому, мне кажется, что здесь все-таки нужен кейс, чтобы задать условия выбора. Вот кусочек работающей как надо проги:
Код: plaintext
1.
2.
3.
4.
5.
6.
7.
8.
9.
...   
  Select Case ThisWorkbook.Sheets(sheet.Name).Range("A1").Value
            Case "7119465", "7139189", "7114973", "7179677", "7554480"
                sheet.Copy Before:=Workbooks(book1).Sheets( 1 )
            Case "7667670"
                sheet.Copy Before:=Workbooks(book2).Sheets( 1 )
            Case "7108518", "7108521", "7206279", "7420526"
                sheet.Copy Before:=Workbooks(book3).Sheets( 1 )    
           
...

[/quot]

Или я туплю в силу своей неопытности, или вы недопоняли меня.

k-nike
Ты хоть пробовала его запускать-то?
Конечно пробовала, она раскидывает каждый лист в отдельный файл, и называет этот файл вот этой вот А1 ячейкой, т.е. номером находящимся в ней.
...
Рейтинг: 0 / 0
| Ответить | Цитировать | Написать  
19.09.2005, 15:09:42
    #33276865
Пользователь2
Пользователь2
Гость
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
Запись определенных листов в определенные файлы согласно условию
k-nikeИными словами, тебе даже и не надо вводить названия отделов - они сами "введутся".

А по поводу переименования: в этом примере файлы автоматически создаются и сохраняются под именами отделов в папке d:\1\ (меняется переменной strPath)

Ты хоть пробовала его запускать-то?

k-nike понял мою идею.
...
Рейтинг: 0 / 0
| Ответить | Цитировать | Написать  
19.09.2005, 15:11:21
    #33276875
Пользователь2
Пользователь2
Гость
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
Запись определенных листов в определенные файлы согласно условию
Вот в чем дело! Оказывается в А1 не названия отделов, а некие семизначные номера, группа которых относится к тому или иному отделу. Надо программу менять. :)
...
Рейтинг: 0 / 0
| Ответить | Цитировать | Написать  
19.09.2005, 15:58:39
    #33277058
k-nike
k-nike
Участник
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
Запись определенных листов в определенные файлы согласно условию
Код: plaintext
1.
2.
3.
4.
5.
6.
7.
8.
9.
10.
11.
12.
13.
14.
15.
16.
17.
18.
19.
20.
21.
22.
23.
24.
25.
26.
27.
28.
29.
30.
31.
32.
33.
34.
35.
36.
37.
38.
39.
40.
41.
42.
43.
44.
45.
46.
Option Explicit

Sub process1()
    Dim i As Integer
    Dim sheet As Worksheet
    Dim book1, book2, book3, book4, book5, book6, book7, Path As String
    
    Workbooks.Add: book1 = ActiveWorkbook.Name
    Workbooks.Add: book2 = ActiveWorkbook.Name
    Workbooks.Add: book3 = ActiveWorkbook.Name
    Workbooks.Add: book4 = ActiveWorkbook.Name
    Workbooks.Add: book5 = ActiveWorkbook.Name
    Workbooks.Add: book6 = ActiveWorkbook.Name
    Workbooks.Add: book7 = ActiveWorkbook.Name
    ThisWorkbook.Activate
    
    For Each sheet In ThisWorkbook.Sheets
        
        Select Case ThisWorkbook.Sheets(sheet.Name).Range("A1").Value
            Case "условие1"
                sheet.Copy Before:=Workbooks(book1).Sheets( 1 )
            Case "условие2"
                sheet.Copy Before:=Workbooks(book2).Sheets( 1 )
            Case "условие3"
                sheet.Copy Before:=Workbooks(book3).Sheets( 1 )
            Case "условие4"
                sheet.Copy Before:=Workbooks(book4).Sheets( 1 )
            Case "условие5"
                sheet.Copy Before:=Workbooks(book5).Sheets( 1 )
            Case "условие6"
                sheet.Copy Before:=Workbooks(book6).Sheets( 1 )
            Case "условие7"
                sheet.Copy Before:=Workbooks(book7).Sheets( 1 )
        End Select
    Next
    Path = "D:\1\"
    Application.DisplayAlerts = False
    Workbooks(book1).SaveAs Path & "отдел1.xls"
    Workbooks(book2).SaveAs Path & "отдел2.xls"
    Workbooks(book3).SaveAs Path & "отдел3.xls"
    Workbooks(book4).SaveAs Path & "отдел4.xls"
    Workbooks(book5).SaveAs Path & "отдел5.xls"
    Workbooks(book6).SaveAs Path & "отдел6.xls"
    Workbooks(book7).SaveAs Path & "отдел7.xls"
    Application.DisplayAlerts = True
    
End Sub
Это посмотри.
...
Рейтинг: 0 / 0
| Ответить | Цитировать | Написать  
20.09.2005, 10:38:21
    #33278054
xiao
xiao
Участник
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
Запись определенных листов в определенные файлы согласно условию
k-nike
Код: plaintext
1.
2.
3.
4.
5.
6.
7.
8.
9.
10.
Option Explicit

Sub process1()
    ...
    Path = "D:\1\"
    Application.DisplayAlerts = False
    Workbooks(book1).SaveAs Path & "отдел1.xls"
    ...
    Application.DisplayAlerts = True
    
End Sub
Это посмотри.
Вооот!! то что нужно!! Спасибо ОГРОМНОЕ!!
...
Рейтинг: 0 / 0
| Ответить | Цитировать | Написать  
23.09.2005, 09:47:13
    #33285175
xiao
xiao
Участник
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
Запись определенных листов в определенные файлы согласно условию
Слушайте, у меня есть файл эксель в котором в одном столбце все эти номера, а в другом название отдела, может значения из А1 ячеек сравнивать с этим столбцом и в соответствие с названием отдела из соседней ячейки второго столбца записывать в нужный файл.
...
Рейтинг: 0 / 0
| Ответить | Цитировать | Написать  
Форумы / Microsoft Office [игнор отключен] [закрыт для гостей] / Запись определенных листов в определенные файлы согласно условию / 15 сообщений из 15, страница 1 из 1
Найденые пользователи ...
Разблокировать пользователей ...
Читали тему (0):
Читали форум (0):
Пользователи онлайн (0):
Польз. соглашение  
Полит. конфиден.  
созд. / загр.: 347ms
Закрыть
start [/forum/topic.php?fid=61&mobile=1&tid=2185719]:
 0ms
get settings:
 7ms
get forum list:
 15ms
check forum access:
 3ms
check topic access:
 3ms
track hit:
 74ms
get topic data:
 7ms
get forum data:
 2ms
get page messages:
 31ms
get tp. blocked users:
 1ms
others: 204ms
total:  347ms
x
x
Закрыть


Просмотр
0 / 0
Close
Debug Console [Select Text]