flexoleonhart
Newbie | Редактировать | Профиль | Сообщение | Цитировать | Сообщить модератору
Sub Создание_реестра()
Dim ee As String
Naim1 = ActiveWorkbook.Name
Basa = "База данных"
ee = InputBox("Введите номер месяца и год для которого необходимо создать новый файл", "Деньги от филиала")
If ee = "" Then
Exit Sub
End If
temps = CStr(Trim(ee))
'Chislo = CStr(Left(temps, 2))
mes = CStr(Left(temps, 2)) 'CStr(Right(Left(temps, 5), 2))
god = CStr(Right(temps, 2))
'datstr = Chislo + Mes + God
Sheets("Реестр_шаблон").Select
Sheets("Реестр_шаблон").Copy
ActiveWorkbook.SaveAs Filename:= _
"Z:\Zayavki_reestr\2011\Reestr_" & mes & "_20" & god & ".xls", FileFormat:=xlNormal, Password:="", WriteResPassword:="", ReadOnlyRecommended:=False _
, CreateBackup:=False
Sheets("Реестр_шаблон").Select
Sheets("Реестр_шаблон").Name = "01" & mes & god
d = "01/" & mes & "/" & god
dd = CDate(d)
Range("B1") = dd
If (mes = "01" Or mes = "03" Or mes = "05" Or mes = "07" Or mes = "08" Or mes = "10" Or mes = "12") Then
Days = 31
ElseIf (mes = "04" Or mes = "06" Or mes = "09" Or mes = "11") Then
Days = 30
Else
Days = 29
End If
Sheets(1).Select
For i = 2 To Days
Sheets(1).Select
Sheets(1).Copy After:=Sheets(i - 1)
Sheets(i).Select
If i > 9 Then
ii = i
Else
ii = "0" & i
End If
nazv = ii & mes & god
Sheets(i).Name = ii & mes & god
Range("B1").Select
rr = ii & "/" & mes & "/" & god
r = CDate(rr)
Range("B1").Value = r
Next
Worksheets(1).Activate
Range("B5").Select
ActiveWorkbook.Close savechanges:=1
End Sub
Sub Реестр_занесение()
Dim zanes(100) As Variant
On Error Resume Next
zayavki = ActiveWorkbook.Name
data = Workbooks(zayavki).Sheets("Шаблон").Cells(3, 5)
chislo = Left(data, 2)
mes = Right(Left(data, 5), 2)
god = Right(data, 2)
datstr = chislo & mes & god
datstr1 = "01" & mes & god
'COUNTER START
' foldcounter = "Z:\Zayavki_reestr\20" & god & "\"
foldcounter = "Z:\Zayavki_reestr\2011\"
filecounter = "Counter.xls"
pathcounter = foldcounter & filecounter
Workbooks.Open Filename:=pathcounter, ReadOnly:=0, Password:="0101"
zcounterold = Workbooks(filecounter).Sheets("1").Cells(1, 256)
If zcounterold = 0 Then
Workbooks(filecounter).Close savechanges:=0
Application.ScreenUpdating = True
MsgBox ("Ошибка,.. ну ты и зануда ..попробуйте еще раз...")
Exit Sub
End If
zcounter = zcounterold + 1
Workbooks(filecounter).Sheets("1").Cells(1, 256) = zcounter
Workbooks(filecounter).Sheets("1").Cells(1, 255) = chislo
Workbooks(filecounter).Close savechanges:=1
'COUNTER END
Workbooks(zayavki).Sheets("Шаблон").Cells(1, 16) = zcounter
zanes(1) = zcounter
'дата заявки
zanes(3) = Workbooks(zayavki).Sheets("Шаблон").Cells(3, 5)
'инициатор
zanes(4) = Workbooks(zayavki).Sheets("Шаблон").Cells(5, 5)
'сумма
zanes(5) = CDbl(Workbooks(zayavki).Sheets("Шаблон").Cells(25, 5))
'курс
zanes(6) = Workbooks(zayavki).Sheets("Шаблон").Cells(22, 16)
'платёж
zanes(7) = "=RC[-2]*RC[-1]"
'комментарий
zanes(8) = Workbooks(zayavki).Sheets("Шаблон").Cells(27, 5)
'статус
zanes(9) = 2
'предполагаемая дата платежа
zanes(10) = Workbooks(zayavki).Sheets("Шаблон").Cells(3, 16)
'клиент
zanes(11) = Workbooks(zayavki).Sheets("Шаблон").Cells(7, 5)
'договор
zanes(12) = Workbooks(zayavki).Sheets("Шаблон").Cells(8, 5)
'приложение
zanes(13) = Workbooks(zayavki).Sheets("Шаблон").Cells(9, 5)
'проект
zanes(14) = Workbooks(zayavki).Sheets("Шаблон").Cells(11, 5)
'статья
zanes(15) = Workbooks(zayavki).Sheets("Шаблон").Cells(13, 5)
'город
zanes(16) = Workbooks(zayavki).Sheets("Шаблон").Cells(15, 5)
'контрагент
zanes(17) = Workbooks(zayavki).Sheets("Шаблон").Cells(17, 5)
'договор
zanes(18) = Workbooks(zayavki).Sheets("Шаблон").Cells(18, 5)
'приложение
zanes(19) = Workbooks(zayavki).Sheets("Шаблон").Cells(19, 5)
'расчёт
zanes(20) = Workbooks(zayavki).Sheets("Шаблон").Cells(21, 5)
'валюта
zanes(21) = Workbooks(zayavki).Sheets("Шаблон").Cells(21, 16)
'счёт
zanes(22) = Workbooks(zayavki).Sheets("Шаблон").Cells(23, 5)
'группа
If zanes(11) = "Офис" Then zanes(23) = "Офис" Else zanes(23) = "Проект"
zanes(26) = "=IF(AND(RC[-6]=""Наличный"", RC[-17]=3, NOT(ISERROR(RC[-19]-RC[-1]))), RC[-19]-RC[-1],"""")"
zanes(28) = Workbooks(zayavki).Sheets("Шаблон").Cells(1, 256)
zanes(29) = "=CONCATENATE(RC[-18],"" - "",RC[-15])"
zanes(30) = CInt(Workbooks(zayavki).Sheets("Шаблон").Cells(5, 256)) + 1
zanes(31) = "NEW"
'налог
zanes(32) = Workbooks(zayavki).Sheets("Шаблон").Cells(25, 12)
Application.Calculation = xlManual
'For m = 1 To 31
For m = 1 To 32
Workbooks(zayavki).Sheets("реестр_шаблон").Cells(1, m) = zanes(m)
Next m
Workbooks(zayavki).Sheets("реестр_шаблон").Cells(1, 26).FormulaR1C1 = zanes(26)
Workbooks(zayavki).Sheets("реестр_шаблон").Cells(1, 29).FormulaR1C1 = zanes(29)
Application.Calculation = xlAutomatic
Workbooks(zayavki).Sheets("реестр_шаблон").Activate
Range("A1:Ag1").Select
Selection.Copy
'Application.CutCopyMode = False
' foldreestr = "Z:\Zayavki_reestr\20" & god & "\"
foldreestr = "Z:\Zayavki_reestr\2011\"
reestr = "Reestr_" & mes & "_20" & god & ".xls"
pathreestr = foldreestr & reestr
Workbooks.Open Filename:=pathreestr, ReadOnly:=0, Password:="0505", WriteResPassword:="0505"
'CHG2
If Workbooks(reestr).Sheets(datstr).Cells(1, 2) = "" Then
Workbooks(reestr).Close savechanges:=0
Application.CutCopyMode = False
Workbooks(zayavki).Sheets("реестр_шаблон").Activate
Sheets("реестр_шаблон").Select
Range("A1:AF1").Select
Selection.ClearContents
Module1.clear_shablon
Application.ScreenUpdating = True
Application.Calculation = xlAutomatic
MsgBox ("Ошибка, гы гы попробуйте еще раз...")
Exit Sub
End If
'zcounterold = Workbooks(reestr).Sheets(datstr1).Cells(1, 256)
'zcounter = zcounterold + 1
'Workbooks(reestr).Sheets(datstr1).Cells(1, 256) = zcounter
'Workbooks(reestr).Sheets(datstr1).Cells(1, 255) = chislo
'Workbooks(zayavki).Sheets("Шаблон").Cells(1, 16) = zcounter
'zanes(1) = zcounter
Workbooks(reestr).Sheets(datstr).Activate
n = 4
While Workbooks(reestr).Sheets(datstr).Cells(n, 1) <> ""
n = n + 1
Wend
'm = 1
'While Workbooks(reestr).Sheets(datstr).Cells(3, m) <> ""
'Workbooks(reestr).Sheets(datstr).Cells(n, m) = zanes(m)
'm = m + 1
'Wend
Workbooks(reestr).Sheets(datstr).Cells(n, 1).Select
ActiveSheet.Paste
Application.CutCopyMode = False
' *ZANESENIE*
'For m = 1 To 27
' Workbooks(reestr).Sheets(datstr).Cells(n, m) = zanes(m)
'Next m
'Workbooks(reestr).Sheets(datstr).Cells(n, 24).FormulaR1C1 = zanes(24)
'Workbooks(reestr).Sheets(datstr).Cells(n, 26).FormulaR1C1 = zanes(26)
' //
Workbooks(reestr).Close savechanges:=1
Workbooks(zayavki).Sheets("реестр_шаблон").Activate
Sheets("реестр_шаблон").Select
Range("A1:AF1").Select
Selection.ClearContents
End Sub
Sub Смета_занесение()
zayavki = ActiveWorkbook.Name
klient = Workbooks(zayavki).Sheets("Шаблон").Cells(7, 5)
proekt = Workbooks(zayavki).Sheets("Шаблон").Cells(11, 5)
klpr = klient & " - " & proekt
ttt = "0101"
smet1folder = "Z:\Zayavki_reestr\2011\"
smet1 = "smet1.xls"
smet1path = smet1folder & smet1
Workbooks.Open Filename:=smet1path, ReadOnly:=0, Password:=ttt
wscount = Workbooks(smet1).Sheets.Count
For i = 1 To wscount
If Workbooks(smet1).Sheets(i).Name = klpr Then GoTo ok2
Next i
Workbooks(smet1).Close savechanges:=0
MsgBox ("Ошибка! Нет данных о смете проекта "" " & klpr & "")
Exit Sub
ok2:
m = CInt(Workbooks(zayavki).Sheets("Шаблон").Cells(5, 256))
Workbooks(smet1).Sheets(klpr).Cells(m + 1, 3) = Workbooks(smet1).Sheets(klpr).Cells(m + 1, 3) + CDbl(Workbooks(zayavki).Sheets("Шаблон").Cells(25, 5))
Workbooks(smet1).Close savechanges:=1
End Sub
Sub procedure_prn()
'xxx
If Sheets("Шаблон").Cells(5, 256) = "" Then
MsgBox ("Необходимо заново создать заявку через кнопку ""Создать заявку""")
Sheets("Запуск").Activate
Exit Sub
End If
Application.ScreenUpdating = False
Module1.Реестр_занесение
If Sheets("Шаблон").Cells(1, 16) = "" Then
Application.ScreenUpdating = True
Exit Sub
End If
If Sheets("Шаблон").Cells(5, 256) <> "" Then
If CInt(Sheets("Шаблон").Cells(5, 256)) > -1 Then
Module1.Смета_занесение
End If
End If
Sheets("Шаблон").Cells(5, 256) = ""
Sheets("Шаблон").Activate
'ZZZ
ActiveSheet.PageSetup.PrintArea = "$A$1:$R$47"
Range("P1:R1").Select
ActiveWindow.SelectedSheets.PrintOut Copies:=1, Collate:=True
'CommandBars("Standard").Controls(6).Enabled = True
Sheets("Запуск").Activate
Application.ScreenUpdating = True
End Sub
Sub clear_shablon()
Sheets("Шаблон").Range("p1:r3").ClearContents
Sheets("Шаблон").Range("p21:r22").ClearContents
Sheets("Шаблон").Range("e5:r19").ClearContents
Sheets("Шаблон").Range("e21:h25").ClearContents
Sheets("Шаблон").Range("e27:r31").ClearContents
Sheets("Шаблон").Range("k25:r25").ClearContents
End Sub
|
Всего записей: 4 | Зарегистр. 21-12-2009 | Отправлено: 17:16 12-08-2011 | Исправлено: flexoleonhart, 17:44 12-08-2011 |
|
