Поиск  Пользователи  Правила  Войти
Форумы "Планета Excel" » Вопросы по Microsoft Excel (архив)
Страницы: 1
RSS
Разбить данные по листам макросом.
 
#1
03.05.2011 15:34:35
Добрый день!  
 
В файле есть лист Общий, откуда ориентируясь на столбец D необходимо скопировать строки в другие листы макросом, предварительно эти листы создав согласно названию из столбца. Помогите, пожалуйста решить этот вопрос!
 
 
 
#2
03.05.2011 15:37:34
<EM>http://excel-vba.ru/index.php?file=MyAddin_Breack_Ranges</EM>
Даже самый простой вопрос можно превратить в огромную проблему. Достаточно не уметь формулировать вопросы...
 
 
 
#3
03.05.2011 15:42:44
{quote}{login=The_Prist}{date=03.05.2011 03:37}{thema=}{post}<EM>http://excel-vba.ru/index.php?file=MyAddin_Breack_Ranges</EM>{/post}{/quote}  
 
Спасибо, только можно ли это сделать макросом?
 
 
 
#4
03.05.2011 15:45:39
Option Explicit  
 
Sub CopyData()  
 
   Dim arr As Variant, i As Integer  
     
   arr = Array("Задолженность_МД", "Справочная", "Юр. лица")  
     
   With Лист1  
       For i = 0 To UBound(arr)  
           .Range("A1:F1").AutoFilter Field:=5, Criteria1:=arr(i)  
           .Cells.SpecialCells(xlCellTypeVisible).Copy _  
               Destination:=Sheets(arr(i)).Range("A1")  
           .Range("A1:F1").AutoFilter  
       Next  
         
   End With  
 
End Sub
There is no knowledge that is not power
 
 
 
#5
03.05.2011 16:04:35
При запуске макроса выдает ошибку и выделяет строчку .Range("A1:F1").AutoFilter Field:=5, Criteria1:=arr(i)
 
 
 
#6
03.05.2011 16:11:43
Вместо "With Лист1" напиши "With Sheets("Лист1")".
There is no knowledge that is not power
 
 
 
#7
03.05.2011 16:20:17
Теперь выдает ошибку в строке: .Cells.SpecialCells(xlCellTypeVisible).Copy _  
Destination:=Sheets(arr(i)).Range("A1")
 
 
 
#8
03.05.2011 16:26:38
Проверь, все ли листы у тебя есть?  
"Задолженность_МД", "Справочная", "Юр. лица"?
There is no knowledge that is not power
 
 
 
#9
03.05.2011 16:55:57
Небольшой макрос. На больших объемах данных должен летать ).
Редко но метко ...
 
 
 
#10
03.05.2011 18:47:31
Если с наименованиями листов вопросов не будет, то я бы так сделал.  
 
Sub add_sheets_value()  
Application.ScreenUpdating = 0  
'R Dmitry  
Dim cn As ADODB.Connection, rs As ADODB.Recordset, lr&  
Set cn = New ADODB.Connection  
Set rs = New ADODB.Recordset  
Set rs2 = New ADODB.Recordset  
cn.Open "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & ThisWorkbook.FullName _  
& ";Extended Properties=""Excel 8.0;HDR=No"";"  
If Not cn.State = 1 Then Exit Sub  
With Worksheets("Общий")  
lr = .Cells(.Rows.Count, 1).End(xlUp).Row  
End With  
strSql = "SELECT DISTINCT F5" _  
& " FROM [Общий$a2:f" & lr & "] T "
rs.Open strSql, cn, adOpenStatic, adLockReadOnly  
rs2.Open "SELECT * FROM [Общий$a2:f" & lr & "] T ", cn, adOpenStatic, adLockReadOnly
For i = 0 To rs.RecordCount - 1  
Worksheets.Add After:=Worksheets(Worksheets.Count)  
With ActiveSheet  
   .Name = rs("F5").Value  
   rs2.Filter = "F5 = '" & rs("F5").Value & "' "  
   .[a1:f1] = Sheets("Общий").[a1:f1].Value
   .Cells(2, 1).CopyFromRecordset rs2  
   rs2.Filter = ""  
   rs.MoveNext  
End With  
Next  
rs.Close: rs2.Close: cn.Close  
Set cn = Nothing: Set rs = Nothing: Set rs2 = Nothing  
Application.ScreenUpdating = -1  
End Sub
Спасибо
 
 
 
#11
04.05.2011 02:03:17
Ещё вариант:
 
 
 
#12
04.05.2011 16:09:02
Спасибо всем большое! Я тоже нашла все таки вариант:  
Sub Tst()  
 
Dim x As Integer  
Dim Found, obj  
x = 2  
While (Worksheets("Общий").Cells(x, 5) <> Empty)  
Found = False  
   For Each Worksheet In Worksheets  
       If Worksheets("Общий").Cells(x, 5) = Worksheet.name Then  
       Found = True  
       retval = CopyPaste(Worksheet.name, x)  
       Exit For  
       End If  
   Next  
If Found = False Then  
Worksheets.Add After:=Worksheets("Общий")  
Sheets(2).name = Worksheets("Общий").Cells(x, 5).Value  
retval = CopyPaste(Sheets(2).name, x)  
End If  
x = x + 1  
Wend  
End Sub  
Function CopyPaste(name As String, num As Integer)  
Dim x As Integer  
x = 1  
While (Worksheets(name).Cells(x, 1) <> Empty)  
x = x + 1  
Wend  
Worksheets("Общий").Activate  
   Range(Cells(num, 2), Cells(num, 6)).Select  
   Selection.Copy  
   Worksheets(name).Activate  
   Worksheets(name).Range(Cells(x, 2), Cells(x, 6)).Select  
     
   With Worksheets(name)  
   .Range(Cells(x, 2), Cells(x, 6)).PasteSpecial Paste:=xlPasteColumnWidths  
   .Paste Destination:=Range(Cells(x, 2), Cells(x, 6))  
   End With  
     
Cells(x, 1) = x  
End Function  
 
Этот макрос работает, только если в книге этот лист стоит первым, может кому и это пригодиться...
 
 
 
Страницы: 1
Наверх