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 |
|