{quote}{login=slan}{date=05.01.2008 11:38}{thema=}{post}пож-та :)  
 
Sub check_new_positions()  
   Dim r_prog As Integer  
   r_prog = prog  
   prog = 1  
   If r_prog <> 1 Then Application.ScreenUpdating = False  
   Dim barcol As Integer, nbook As String, rbook As String, basebook As String  
   barcol = ActiveCell.column  
   rbook = ActiveWorkbook.name  
   Workbooks.Open Filename:=bd_path & pack_name  
   basebook = ActiveWorkbook.name  
   Range("A1").Select  
   Range(Selection, Cells(ActiveCell.SpecialCells(xlLastCell).Row, 1)).Select  
   Selection.Copy  
   Workbooks.Add  
   nbook = ActiveWorkbook.name  
   ActiveSheet.Paste  
   ActiveCell.SpecialCells(xlLastCell).Select  
   ActiveCell.Offset(1, 0).Select  
   Dim erow As Long  
   erow = Selection.Row  
   Workbooks(rbook).Activate  
   Cells(1, barcol).Select  
   Range(Selection, Cells(ActiveCell.SpecialCells(xlLastCell).Row, barcol)).Select  
   Application.CutCopyMode = False  
   Selection.Copy  
   Workbooks(nbook).Activate  
   ActiveSheet.Paste  
   Range("B1").Select  
   Application.CutCopyMode = False  
   ActiveCell.FormulaR1C1 = "1"  
   Range(Selection, ActiveCell.SpecialCells(xlLastCell)).Select  
   Selection.FillDown  
   Selection.Copy  
   Range("A1").Select  
   Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlMultiply, _  
       SkipBlanks:=False, Transpose:=False  
   Columns("B:B").Select  
   Application.CutCopyMode = False  
'    Selection.Delete Shift:=xlToLeft  
   Range("B1").Select  
   ActiveCell.FormulaR1C1 = "1"  
   Range(Selection, ActiveCell.SpecialCells(xlLastCell)).Select  
   Selection.DataSeries Rowcol:=xlColumns, Type:=xlLinear, Date:=xlDay, _  
       Step:=1, Trend:=False  
   Range("A2").Select  
   Range(Selection, ActiveCell.SpecialCells(xlLastCell)).Select  
   Selection.Sort Key1:=Range("A2"), Order1:=xlAscending, Header:=xlGuess, _  
       OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _  
       DataOption1:=xlSortNormal  
   Range("C2").Select  
   ActiveCell.FormulaR1C1 = _  
       "=IF(AND(RC[-2]<>0,ISNUMBER(RC[-2]),RC[-2]<>R[-1]C[-2]),7)"
   Range(Selection, ActiveCell.SpecialCells(xlLastCell)).Select  
   Selection.FillDown  
     
     
'        Cells(1, 5).FormulaR1C1 = "=INDEX([" & wpbar & "]Âîññòàíîâë_Ëèñò1!C1,MATCH(RC[-4],[" & wpbar & "]Âîññòàíîâë_Ëèñò1!C2,0))"
     
   Columns("C:C").Select  
   Selection.Copy  
   Range("D1").Select  
   Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _  
       :=False, Transpose:=False  
   Application.CutCopyMode = False  
     
   Columns("C:C").Select  
   Selection.Delete (xlShiftToLeft)  
   Range("A2").Select  
   Range(Selection, ActiveCell.SpecialCells(xlLastCell)).Select  
   Selection.Sort Key1:=Range("b2"), Order1:=xlAscending, Header:=xlGuess, _  
       OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _  
       DataOption1:=xlSortNormal  
   Range(Cells(2, 1), Cells(erow - 1, 3)).Select  
   Selection.Delete Shift:=xlUp  
   Range(Cells(1, 1), ActiveCell.SpecialCells(xlLastCell)).Select  
   Selection.AutoFilter  
   Selection.AutoFilter Field:=3, Criteria1:="=7", Operator:=xlAnd  
   Selection.Copy  
     
   Sheets.Add  
   ActiveSheet.Paste  
   Call add_new_positions  
   If r_prog <> 1 Then  
       Application.ScreenUpdating = True  
   End If  
   prog = r_prog  
End Sub{/post}{/quote}