блин, срочно нужно кое что автоматизировать, и из-за этого башка маманегорюй - вааааще не соображает.
давно я этим не занимался... забыл всё на свете, а надо вспомнить, НАДО!!!
вот завершил первый этап.




Sub Ìàêðîñ2()
'
' Ìàêðîñ2 Ìàêðîñ
' Ìàêðîñ çàïèñàí 20.01.2005 (Ryabikov)
'

'
ActiveWorkbook.SaveAs Filename:= _
"F:\Èíôðàñòðóêòóðíûå ïðîåêòû\ïðîãðàììà àâòîìàòèçàöèè\òåêóùèé ñòàòóñ.xls", FileFormat:= _
xlNormal, Password:="", WriteResPassword:="", ReadOnlyRecommended:=False _
, CreateBackup:=False
Workbooks.Open Filename:= _
"F:\Èíôðàñòðóêòóðíûå ïðîåêòû\ïðîãðàììà àâòîìàòèçàöèè\øàïêà.xls"
Sheets(Array("õîä ðåàëèçàöèè ÈÑÏ", "Ñïðàâêà")).Select
Sheets("Ñïðàâêà").Activate
Sheets(Array("õîä ðåàëèçàöèè ÈÑÏ", "Ñïðàâêà")).Copy Before:=Workbooks( _
"òåêóùèé ñòàòóñ.xls").Sheets(1)
Windows("øàïêà.xls").Activate
ActiveWindow.Close
Workbooks.Open Filename:= _
"F:\Èíôðàñòðóêòóðíûå ïðîåêòû\ïðîãðàììà àâòîìàòèçàöèè\ÈÑÏ.xls"

'With Application
' .ReferenceStyle = xlA1
'End With

'Range(1, 1).Select

' Dim year_(10) As String
' Dim net_(20) As String
' Dim project_(100) As String
Dim work1(20) As String
Dim work2(20) As String
cell = 4 ' íîìåð ñòðîêè â òàáëèöå êóäà âñòàâëÿåì äàííûå

' form = ActiveCell.Formula


' ïðîõîäèì âåñü ôàéë äî êîíöà ïî ïåðâîé êîëîíêå

i = 1
j = 1
num = 1 ' íîìåð ïðîåêòà ïî ïîðÿäêó
string_ = Cells(i, j)

Do While string_ <> Empty


' ðàçáîð ñòðóêòóðû
' ur - óðîâåíü â ñòðóêòóðå
' dig - ÷èñëî â óðîâíå

nplace = InStr(string_, ".")
If Len(string_) > 0 Then

ur = 1

Do While nplace > 0
string_ = Mid(string_, nplace + 1)
nplace = InStr(string_, ".")
ur = ur + 1
Loop

i_ = 1
str_l = ""
Do While i_ <= Len(string_)
str_l = str_l + Mid(string_, i_, 1)
i_ = i_ + 1
Loop
dig = Val(str_l) ' ïîëó÷èëè ÷èñëî

End If

' êîíåö ðàçáîðà ñòðóêòóðû


' Åñëè ýòî ãîä ïðîåêòà, òî âñòàâëÿåì åãî â òàáëèöó
If ur = 1 Then
year_ = Cells(i, j + 1)

' ðàçìåùàåì äàííûå â òàáëèöó
Windows("òåêóùèé ñòàòóñ.xls").Activate
Sheets("õîä ðåàëèçàöèè ÈÑÏ").Activate
Cells(cell, 1) = year_

' îáúåäèíèëè ÿ÷åéêè âî âñþ äëèíó òàáëèöû
Range("A4:AE4").Select
With Selection
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlBottom
.WrapText = False
.Orientation = 0
.AddIndent = False
.ShrinkToFit = False
.MergeCells = False
End With
Selection.Merge
cell = cell + 1

' âîçâðàùàåìñÿ ê äàííûì èç Ïðîäæåêòà
Windows("ÈÑÏ.xls").Activate

End If
' âñòàâèëè ãîä ïðîåêòà

' çàïîìèíàåì ñåòü ïðèíàäëåæíîñòè ïðîåêòà
If ur = 2 Then
net = Cells(i, j + 1)
End If

' çàïîìèíàåì íàçâàíèå ïðîåêòà, êîä òèòóëà, íîìåð Èòð,áþäæåò ïî ïåðå÷íþ, áþäæåò ïî ÒÝÎ
If ur = 3 Then
P_name = Cells(i, j + 1)
titul = Cells(i, j + 2)
n_itr = Cells(i, j + 3)
budget1 = Cells(i, j + 4)
budget2 = Cells(i, j + 5)
End If
'ðàçáèðàåì çàäà÷è â ïðîåêòå è äàòû íà÷àëà è îêîí÷àíèÿ
If ur = 4 Then
For k = 1 To 12
data = Cells(i, j + 6)
If data = "ÍÄ" Then
work1(k) = ""
Else
work1(k) = data
End If
data = Cells(i, j + 7)
If data = "ÍÄ" Then
work2(k) = ""
Else
work2(k) = data
End If

' k = k + 1
i = i + 1
Next
' ðàçìåùàåì äàííûå â òàáëèöó
Windows("òåêóùèé ñòàòóñ.xls").Activate
Sheets("õîä ðåàëèçàöèè ÈÑÏ").Activate

Cells(cell, 1) = num
Cells(cell, 2) = net
Cells(cell, 3) = P_name
Cells(cell, 4) = n_itr
Cells(cell, 5) = titul
n = 6
For k = 1 To 12
If k <> 4 Then ' ðàçðàáîòêà ÒÇ íå èìååò äàííûõ íà÷àëà ïî ïëàíó
Cells(cell, n) = work1(k)
n = n + 1
End If
Cells(cell, n) = work2(k)

n = n + 1
Next
Cells(cell, 29) = budget1
Cells(cell, 30) = budget2

Windows("ÈÑÏ.xls").Activate
' âîçâðàòèëèñü ê äàííûì èç Ïðîäæåêòà
num = num + 1 ' óâåëè÷èëè íîìåð ïðîåêòà
i = i - 1

End If




i = i + 1 ' óâåëè÷èëè íîìåð ñòðîêè
string_ = Cells(i, j)
Loop



End Sub