Sub KomPred(wbold As Workbook, load_pic As String)
Application.Calculation = xlCalculationManual
Dim flag As Boolean
70 Application.ScreenUpdating = False
80 With Sheets(gsSTART_NAME).Range("C22")
90 End With
100 With Sheets(gsSMETA_NAME)
Dim lr As Integer
110 lr = .Range(gsONES_COLUMN_SMETA & .Rows.Count).End(xlUp).Row
120 .Range("$A$11:$Z$" & lr).AutoFilter Field:=giONES_COLUMN_FILTER
130 .Range("filter_p").Value = 2
140 .Unprotect Password:="5029"
150 End With
160 Sheets(Array(gsMENU_NAME, gsMAIN_NAME, gsSMETA_NAME, gsOPTION_NAME, gsABOUT_NAME)).Copy '!!!1
170 wbold.Worksheets(gsSMETA_NAME).Protect Password:="5029", DrawingObjects:=True, Contents:=True, Scenarios:=True, UserInterfaceOnly:=True
180 Sheets(gsABOUT_NAME).Visible = True
Dim wbKP As Workbook ', vbc As VBComponent
190 Set wbKP = ActiveWorkbook
200 With wbKP
210 .PrecisionAsDisplayed = True 'точность, как на экране
220 With .Worksheets(gsMAIN_NAME) '!!!
230 Range2Value .Range("A1:B50")
240 Range2Value .Range("C1:C15")
250 Range2Value .Range("Opisanie_fundament")
260 Range2Value .Range("C25")
270 .PageSetup.PrintArea = "$A$1:$C$49"
280 End With
290 With .Worksheets(gsABOUT_NAME) ' О НАС
300 .Activate
310 .Range("B3").Select
320 ActiveWindow.DisplayHeadings = False
330 ActiveWindow.DisplayGridlines = False
340 .UsedRange
350 End With
360 With .Worksheets(gsMENU_NAME) 'МЕНЮ
370 .Activate
380 Range2Value .Range("C10:F10")
390 ActiveWindow.DisplayHeadings = False
400 ActiveWindow.DisplayGridlines = False
410 .Range("D16").Select
420 .UsedRange
430 End With
440 With .Worksheets(gsSMETA_NAME) ' СМЕТА
Dim tsmeta
Dim lrrrr
lrrrr = lr - 66
450 tsmeta = .Range("U7")
460 .Activate
470 .Range("A6").Value = "КОММЕРЧЕСКОЕ ПРЕДЛОЖЕНИЕ"
480 .Unprotect Password:="5029"
.Range("BA9:BD9").Cut
Range("D8").Select
ActiveSheet.Paste
' .Range("K7") = .Range("K1")
490 Range2Value .Range("S10:S" & lr)
500 Range2Value .Range("A9:B" & lr)
' .Range("K1") = "ЛОЖЬ"
510 Range2Value .Range("D9:E" & lr)
' .Range("K1") = .Range("K7")
520 .Range("M8").Value = .Range("U9")
530 Range2Value .Range("A2:M8")
540 Range2Value .Range("J11:J" & lr)
550 Range2Value .Range("R11:W" & lr)
551 Range2Value .Range("X11:X" & lrrrr)
'560 Range2Value .Range("M11:M" & lr)
570 Range2Value .Range("del_raschet_stat")
' Range2Value .Range("del_minvata")
' Range2Value .Range("del_sofit")
580 Range2Value .Range("del_s")
590 .Rows("11").Delete
' del_Shapes .Shapes
.Shapes("Ф_доп_системы").Delete
600 .DropDowns.Delete
610 .Buttons.Delete
Dim col As Collection
620 get_collection_checkbox Worksheets(gsSMETA_NAME), col
Dim r As Integer
Dim rngG As Range
630 For r = 9 To lr
640 If .Range(gsONES_COLUMN_SMETA & r).Value = 0 Then
650 On Error Resume Next
660 col(CStr(r)).Delete
670 On Error GoTo 0
680 If rngG Is Nothing Then
690 Set rngG = .Range("A" & r)
700 Else
710 Set rngG = Union(.Range("A" & r), rngG)
720 End If
730 End If
740 Next
750 If Not rngG Is Nothing Then
760 rngG.EntireRow.Delete
770 End If
Dim h
780 On Error Resume Next
790 For Each h In .Hyperlinks
800 h.Range.Style = "Hyperlink"
810 Next
820 With ActiveWorkbook.Styles("Hyperlink").Font
830 .Name = "Arial Narrow"
840 .Size = 11
850 .Bold = False
860 .Italic = True
870 .Underline = xlUnderlineStyleNone
880 .Strikethrough = False
890 .Color = -131072
900 .TintAndShade = 0
910 .ThemeFont = xlThemeFontNone
920 End With
930 On Error GoTo 0
940 ActiveWindow.FreezePanes = False
950 With ActiveWindow
960 .SplitColumn = 0
970 .SplitRow = 1
980 End With
990 ActiveWindow.FreezePanes = True
' ActiveWindow.DisplayHeadings = False
1000 .Outline.ShowLevels RowLevels:=1, ColumnLevels:=2
1010 .EnableOutlining = True
1020 .CheckBoxes.Visible = True
1030 .Columns("N").Resize(, .UsedRange.Columns.Count).Delete 'Victor
1050 If tsmeta = 1 Then
1060 .Outline.ShowLevels RowLevels:=2, ColumnLevels:=2
' .PageSetup.PrintArea = "$A$2:$I$" & lr2
1070 .PageSetup.LeftMargin = Application.InchesToPoints(0.236220472440945)
1080 .PageSetup.RightMargin = Application.InchesToPoints(0.236220472440945)
1090 .PageSetup.TopMargin = Application.InchesToPoints(0.590551181102362)
1100 .PageSetup.BottomMargin = Application.InchesToPoints(0.590551181102362)
1110 .PageSetup.HeaderMargin = Application.InchesToPoints(0.31496062992126)
1120 .PageSetup.FooterMargin = Application.InchesToPoints(0.31496062992126)
1130 .PageSetup.CenterHorizontally = True
1140 .PageSetup.FitToPagesWide = 1
1150 .PageSetup.FitToPagesTall = False
1160 .PageSetup.Orientation = xlLandscape
1170 Else
1180 .Outline.ShowLevels RowLevels:=1, ColumnLevels:=2
1190 .PageSetup.LeftFooter = "ПОДРЯДЧИК: ______________________________"
1200 .PageSetup.CenterFooter = "Страница &P из &N"
1210 .PageSetup.RightFooter = "ЗАКАЗЧИК: ______________________________"
1220 .PageSetup.LeftMargin = Application.InchesToPoints(0.236220472440945)
1230 .PageSetup.RightMargin = Application.InchesToPoints(0.236220472440945)
1240 .PageSetup.TopMargin = Application.InchesToPoints(0.47244094488189)
1250 .PageSetup.BottomMargin = Application.InchesToPoints(0.47244094488189)
1260 .PageSetup.HeaderMargin = Application.InchesToPoints(0.31496062992126)
1270 .PageSetup.FooterMargin = Application.InchesToPoints(0.31496062992126)
1280 .PageSetup.CenterHorizontally = True
1290 .PageSetup.Zoom = False
1300 .PageSetup.FitToPagesWide = 1
1310 .PageSetup.FitToPagesTall = False
1320 .PageSetup.Orientation = xlPortrait
'XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX
.Rows(8).Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
With .Range("A8:I8")
.Font.Bold = True
.Font.ThemeColor = xlThemeColorAccent2
.Font.TintAndShade = -0.499984740745262
.Interior.Color = 13500415
.HorizontalAlignment = xlCenter
.MergeCells = True
.Cells(1).Value = "ЧТОБЫ ПОЛНОСТЬЮ ОТКРЫТЬ ПОДРОБНУЮ СМЕТУ СВЯЖИТЕСЬ С НАШИМИ СПЕЦИАЛИСТАМИ!"
End With
'XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX
1690 End If
Dim chb As CheckBox, arCheckBox
Dim colOffset&, i&
1700 ReDim arCheckBox(1 To .CheckBoxes.Count, 1 To 2)
1710 wbKP.Sheets.Add After:=wbKP.Sheets(wbKP.Sheets.Count)
1720 wbKP.Sheets(wbKP.Sheets.Count).Name = "В"
1730 wbKP.Sheets(wbKP.Sheets.Count).Visible = 2 'Victor
'.Activate
1740 colOffset = 1 - .Columns("J:M").Column
1750 For Each chb In .CheckBoxes
1760 i = i + 1
1770 Set arCheckBox(i, 1) = chb
1780 arCheckBox(i, 2) = wbKP.Sheets(wbKP.Sheets.Count).Name & "!" & Range(chb.LinkedCell).Offset(, colOffset).Address
1790 Next
1800 .Columns("J:M").Cut
1810 wbKP.Sheets(wbKP.Sheets.Count).Range("A1").Insert
1820 For i = 1 To UBound(arCheckBox)
1830
arCheckBox(i, 1).LinkedCell = arCheckBox(i, 2)
1840 Next
' %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
Dim lr3&
1850 If .AutoFilterMode Then .Range("A1").AutoFilter
1860 lr3 = .Columns(1).Find("ОБЩИЙ ИТОГ ПО ВСЕЙ СМЕТЕ").Row
1870 .Range("A9:A" & lr3).AutoFilter
Dim nm As Name
1890 On Error Resume Next 'Victor
1880 For Each nm In Names
1900 nm.Delete
1910 Next nm
On Error GoTo 0
1920 .Columns("O:AO").Copy
1930 .Columns("J:J").Insert Shift:=xlToRight
Dim lr2 As Integer
1940 lr2 = .Range("I" & .Rows.Count).End(xlUp).Row
1950 .PageSetup.PrintArea = "$A$2:$I$" & lr2
1960 ActiveWindow.ScrollRow = 1
1970 ActiveWindow.ScrollColumn = 1
' .Range("I8").Select
1980 ActiveWindow.FreezePanes = True
1990 ActiveWindow.DisplayGridlines = False
2000 .Range("J2:J7").RowHeight = 20.25
2010 If tsmeta = 0 Then
2020 .Range("J6:J7").RowHeight = 30.25
2030 End If
Dim sOptions$
Dim chk As Excel.CheckBox
2050 For Each chk In .CheckBoxes
2060 sOptions$ = sOptions$ & "," & chk.LinkedCell
2070 Next
2080 sOptions = Mid(sOptions, 2)
.Activate
.Range("D9:G9").Cut
.Range("J1").Select
.Paste
.Range("J1").VerticalAlignment = xlCenter
' ^^^^^^^^^^^^ РАЗМЕТКА ДЛЯ ПЕЧАТИ ^^^^^^^^^^^^^^^
' Dim lrPrintArea&, LocRow&, HPBCounter&, prevLocRow&, nextLocRow&
' ' Application.ScreenUpdating = False
' ActiveWindow.View = xlPageBreakPreview
' ' With ActiveSheet
' On Error Resume Next
'' ar = Sheets(2).UsedRange.Value
' ar = ThisWorkbook.Sheets(1).Range("D1").CurrentRegion.Value ' список раскрываемых строк
'
' lrPrintArea = .Range(.PageSetup.PrintArea).Rows.Count + .Range(.PageSetup.PrintArea).Row - 1
' ' s = "Монтаж металлочерепицы"
' For i = 1 To lrPrintArea
' For j = 1 To UBound(ar)
' If .Cells(i, 1).Value = ar(j, 1) Then
' .Rows(i).ShowDetail = True
' End If
' Next
' Next
' If Err Then Err.Clear
' .ResetAllPageBreaks
' HPBCounter = 1
' LocRow = .HPageBreaks(HPBCounter).Location.Row
' lrPrintArea = .Range(.PageSetup.PrintArea).Rows.Count + .Range(.PageSetup.PrintArea).Row - 1
'
' For i = 1 To lrPrintArea
' If .Cells(i, 1).Value = "НАИМЕНОВАНИЕ" Or i = lrPrintArea Then
' If LocRow < i Then
' nextLocRow = i
' Set .HPageBreaks(HPBCounter).Location = .Range("A" & prevLocRow)
' HPBCounter = HPBCounter + 1
' LocRow = .HPageBreaks(HPBCounter).Location.Row
' prevLocRow = nextLocRow
' If Err Then Err.Clear: Exit For
' Else
' prevLocRow = i
' End If
'
' End If
' Next
' ' End With
' ActiveWindow.View = xlNormalView
' On Error GoTo 0
' ^^^^^^^^^^^^ РАЗМЕТКА ДЛЯ ПЕЧАТИ ^^^^^^^^^^^^^^^
2090 .UsedRange
2100 End With ' СМЕТА
2110 With .Worksheets(gsOPTION_NAME) ' ОПЦИИ
Dim shp As Shape, s$, delRange As Range
2120 .Activate
2130 For Each shp In .Shapes
2140 If TypeName(shp.DrawingObject) = "CheckBox" Then
2150 If InStr(sOptions, Mid(shp.DrawingObject.LinkedCell, InStr(shp.DrawingObject.LinkedCell, "!") + 1)) = 0 Then
2160 s = s & "," & shp.TopLeftCell.Address
2170 shp.Delete
2180 End If
2190 Else
' shp.Delete
2200 If shp.Type <> msoComment Then
2210 shp.Delete
2220 End If
2230 End If
2240 Next
2250 s = Mid(s, 2)
DoEvents
'On Error Resume Next
Application.Wait (Now + TimeValue("0:00:05"))
2260 Set delRange = .Range(s) 'Nothing
22600 Set delRange = delRange.EntireRow 'Nothing
2261 delRange.Delete
'2260 .Range(s).EntireRow.Delete
2270 .Columns("J").Resize(, .UsedRange.Columns.Count).Delete
2280 ActiveWindow.DisplayHeadings = False
2290 ActiveWindow.DisplayGridlines = False
2300 ActiveWindow.ScrollColumn = 1
2310 .Range("C5").Select
2320 .UsedRange
2330 End With
2340 With .Worksheets(gsMAIN_NAME) '!!! блок перенесн поскольку не удалялись строки с пустыми галками пол добавления гиперссылки
2350 On Error Resume Next 'Victor
2360 .Range("C4").Hyperlinks.Add .Range("C4"), wbold.Sheets("СТАРТ").Range("C20").Value, TextToDisplay:=wbold.Sheets("СТАРТ").Range("F20").Value
2370 On Error GoTo 0
2380 End With
2390 .Worksheets("МЕНЮ").Select
2400 Application.ScreenUpdating = True
Call LinksDel
2480 .Sheets("ОБЩАЯ").Name = "ПРОСТАЯ СМЕТА"
2490 .Sheets("СМЕТА").Name = "ПОДРОБНАЯ СМЕТА"
Dim TextMSG$
Dim wb As Workbook
Set wb = wbKP
2500 If Len(load_pic) Then
2510 Call NewPictureSheet(load_pic, wb, TextMSG) ' Call NewPictureSheet(load_pic, wbKP)
2520 End If
2530 .Activate
2540 With .Sheets("МЕНЮ")
2550 .Select
2560 .Range("D18:D19").Hyperlinks(1).SubAddress = "'ПРОСТАЯ СМЕТА'!C7"
' Range("D21:D22").Select
2570 .Range("D21:D22").Hyperlinks(1).SubAddress = "'ПОДРОБНАЯ СМЕТА'!A8"
' Range("D24:D25").Select
2580 .Range("D24:D25").Copy
' Range("D18:D19").Select
2590 .Range("D18:D19").PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
' Range("D21:D22").Select
2600 .Range("D21:D22").PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
2610 Application.CutCopyMode = False
2620 .Range("A1").Select
2630 End With
' Debug.Print .Name
2640 End With 'wbKP
Application.ScreenUpdating = True
'2650 Application.ScreenUpdating = True
' Debug.Print "КП1 - " & ActiveWorkbook.Name
' If TextMSG <> "" Then MsgBox TextMSG 'Вывод сообщения о количестве загруженных изображений
' Debug.Print "КП2 - " & ActiveWorkbook.Name
Application.Calculation = xlCalculationAutomatic
End Sub |