> Автор: MxSv
> Программка будет раздаваться многим пользователям для коррекции ранее выданных файлов, поэтому не хотелось бы
> привязываться к определенной версии Екселя (правда придется все используемые константы еще определить самому (та же
> xlCalculationManual = -4135). Ведь, насколько я понимаю, подключив Библиотеку версии 9.0, программка не заработает ни
> на более старых, ни на более новых версиях (уж извините, новичок в программировании :))
У меня програмка, кочевала с таким референсом с 2000 по 2003 офис, никаких проблем не было, но не знаю как сейчас в
новых версиях, хотя по моему в 2007 офисе должна работать, т.к. ничего экзотического не используется
взял пустой файл, назхвал два листа соответственно Форма 2 и Форма 3, "размножил" его до 392 штук и запустил, программа
обработала все файлы на 0:03:45
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.
75.
76.
77.
78.
79.
80.
81.
82.
83.
84.
85.
86.
87.
88.
89.
Private Sub cmdTxtPath_Click()
'Dim objExcel, objBook As Object
Dim objExcel As Excel.Application
Dim objBook As Excel.Workbook
Dim sh As Excel.Worksheet
Dim F As Long
Dim G As Long
Dim MyFile1 As String
Dim MyFile As String
Dim a As Integer
Dim dtStart As Date
dtStart = Now()
F = 0
G = 0
MyFile1 = Dir(Dir1 & "\\*.xls")
Do While MyFile1 <> ""
G = G + 1
MyFile1 = Dir
Loop
If G <> 0 Then
Set objExcel = CreateObject("Excel.Application")
With objExcel
.Visible = False
.DisplayAlerts = False
.ScreenUpdating = False
End With
' objExcel.WindowState = xlMinimized
If Dir(Dir1 & "\ReMake\", vbDirectory) = "" Then
MkDir Dir1 & "\ReMake\"
End If
End If
Label3.Visible = True
Label4.Visible = True
Label5.Visible = True
Label6.Visible = True
Label3.Caption = CStr(F)
Label6.Caption = CStr(G)
MyFile = Dir(Dir1 & "\\*.xls")
Do While MyFile <> ""
F = F + 1
Set objBook = objExcel.Workbooks.Open(Dir1 & "\\" & MyFile, , False)
'-------------------Форма3------------------------
'objBook.Sheets("Форма 3").EnableCalculation = False
Set sh = objBook.Sheets("Форма 3")
With sh
.Unprotect ("123")
.Range("T15:T58").FormulaR1C1 =
"=IF(AND(OR(RC3<>"""",RC4<>""""),RC1=1,R8C10=""ДА""),IF(RC5=1,RC[17]/15,IF(RC5=2,RC[17]/16)),"""")"
.Range("Y15:Y58").FormulaR1C1 = "=IF(AND(RC5=2,RC[-16]=4),1,0)"
.Range("Z15:Z58").FormulaR1C1 = "=IF(AND(RC5=1,RC[-16]=3),1,IF(AND(RC5=2,RC[-16]=1),1,0))"
.Protect ("123")
End With
'-------------------Форма2------------------------
'objBook.Sheets("Форма 2").EnableCalculation = False
Set sh = objBook.Sheets("Форма 2")
With sh
.Unprotect ("123")
.Range("BH14").AutoFill Destination:=.Range("BH14:BH57"), Type:=xlFillDefault
.Protect ("123")
End With
Set sh = Nothing
objBook.SaveAs FileName:=Dir1 & "\ReMake\" & MyFile, FileFormat:=xlExcel9795
objBook.Close
Set objBook = Nothing
Label3.Caption = CStr(F)
MyFile = Dir
Loop
If G <> 0 Then
Set sh = Nothing
Set objBook = Nothing
objExcel.Application.Quit
Set objExcel = Nothing
End If
MsgBox CStr(CDate(Now() - dtStart))
If F <> 0 Then
MsgBox "Формы удачно исправлены в кол-ве: " & F & " шт.", , "Инфо"
Else
MsgBox "Ни одной формы не найдено", , "Инфо"
End If
End Sub
--
С уважением Горбонос Игорь Леонидович
Posted via ActualForum NNTP Server 1.4
