Sub РАЗБИТИЕстраницыНАлитыСименемОТЧЕТ2SplitToSheets()
Cells.Replace What:="Заявка на выдачу товарно-материальных ценностей со склада № ГС-000", Replacement:="f 0000 ", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
ReplaceFormat:=False, FormulaVersion:=xlReplaceFormula2
Cells.Replace What:="ГС-000", Replacement:="ГС 0000 ", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
ReplaceFormat:=False, FormulaVersion:=xlReplaceFormula2
Dim HPB As HPageBreak
Dim i&, hpbCount&
Dim FirstCell As Range, EndCell As Range, CopyRange As Range
On Error Resume Next
Application.ScreenUpdating = False
With Worksheets("TDSheet")
hpbCount = .HPageBreaks.Count + 1
For i = 1 To hpbCount
Select Case i
Case 1
Set FirstCell = .Range("A1")
Set EndCell = .Range(.HPageBreaks(i).Location.Address).Offset(-1)
Case 2 To hpbCount - 1
Set FirstCell = EndCell.Offset(1)
Set EndCell = .Range(.HPageBreaks(i).Location.Address).Offset(-1)
Case hpbCount
Set FirstCell = EndCell.Offset(1)
Set EndCell = EndCell.Offset(.Cells(.Rows.Count, "A").End(xlUp).Row - EndCell.Row)
End Select
Set CopyRange = .Range(FirstCell, EndCell.Resize(, 33))
CopyRange.Copy
Worksheets.Add After:=Worksheets(Worksheets.Count)
With Worksheets(Worksheets.Count)
' .Range("A1").PasteSpecial Paste:=xlPasteAll
' .Range("A1").Select
Selection.PasteSpecial Paste:=xlPasteColumnWidths, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
ActiveSheet.Paste
ActiveWindow.View = xlPageBreakPreview
Application.CutCopyMode = False
Application.PrintCommunication = False
With ActiveSheet.PageSetup
.PrintTitleRows = ""
.PrintTitleColumns = ""
End With
Application.PrintCommunication = True
ActiveSheet.PageSetup.PrintArea = ""
Application.PrintCommunication = False
With ActiveSheet.PageSetup
.LeftHeader = ""
.CenterHeader = ""
.RightHeader = ""
.LeftFooter = ""
.CenterFooter = ""
.RightFooter = ""
.LeftMargin = Application.InchesToPoints(0.7)
.RightMargin = Application.InchesToPoints(0.7)
.TopMargin = Application.InchesToPoints(0.75)
.BottomMargin = Application.InchesToPoints(0.75)
.HeaderMargin = Application.InchesToPoints(0.3)
.FooterMargin = Application.InchesToPoints(0.3)
.PrintHeadings = False
.PrintGridlines = False
.PrintComments = xlPrintNoComments
.PrintQuality = 600
.CenterHorizontally = False
.CenterVertically = False
.Orientation = xlLandscape
.Draft = False
.PaperSize = xlPaperA4
.FirstPageNumber = xlAutomatic
.Order = xlDownThenOver
.BlackAndWhite = False
.Zoom = 100
.PrintErrors = xlPrintErrorsDisplayed
.OddAndEvenPagesHeaderFooter = False
.DifferentFirstPageHeaderFooter = False
.ScaleWithDocHeaderFooter = True
.AlignMarginsHeaderFooter = True
.EvenPage.LeftHeader.Text = ""
.EvenPage.CenterHeader.Text = ""
.EvenPage.RightHeader.Text = ""
.EvenPage.LeftFooter.Text = ""
.EvenPage.CenterFooter.Text = ""
.EvenPage.RightFooter.Text = ""
.FirstPage.LeftHeader.Text = ""
.FirstPage.CenterHeader.Text = ""
.FirstPage.RightHeader.Text = ""
.FirstPage.LeftFooter.Text = ""
.FirstPage.CenterFooter.Text = ""
.FirstPage.RightFooter.Text = ""
End With
Application.PrintCommunication = True
Application.PrintCommunication = False
With ActiveSheet.PageSetup
.PrintTitleRows = ""
.PrintTitleColumns = ""
End With
Application.PrintCommunication = True
ActiveSheet.PageSetup.PrintArea = ""
Application.PrintCommunication = False
With ActiveSheet.PageSetup
.LeftHeader = ""
.CenterHeader = ""
.RightHeader = ""
.LeftFooter = ""
.CenterFooter = ""
.RightFooter = ""
.LeftMargin = Application.InchesToPoints(0.7)
.RightMargin = Application.InchesToPoints(0.7)
.TopMargin = Application.InchesToPoints(0.75)
.BottomMargin = Application.InchesToPoints(0.75)
.HeaderMargin = Application.InchesToPoints(0.3)
.FooterMargin = Application.InchesToPoints(0.3)
.PrintHeadings = False
.PrintGridlines = False
.PrintComments = xlPrintNoComments
.PrintQuality = 600
.CenterHorizontally = False
.CenterVertically = False
.Orientation = xlLandscape
.Draft = False
.PaperSize = xlPaperA4
.FirstPageNumber = xlAutomatic
.Order = xlDownThenOver
.BlackAndWhite = False
.Zoom = False
.FitToPagesWide = 1
.FitToPagesTall = 0
.PrintErrors = xlPrintErrorsDisplayed
.OddAndEvenPagesHeaderFooter = False
.DifferentFirstPageHeaderFooter = False
.ScaleWithDocHeaderFooter = True
.AlignMarginsHeaderFooter = True
.EvenPage.LeftHeader.Text = ""
.EvenPage.CenterHeader.Text = ""
.EvenPage.RightHeader.Text = ""
.EvenPage.LeftFooter.Text = ""
.EvenPage.CenterFooter.Text = ""
.EvenPage.RightFooter.Text = ""
.FirstPage.LeftHeader.Text = ""
.FirstPage.CenterHeader.Text = ""
.FirstPage.RightHeader.Text = ""
.FirstPage.LeftFooter.Text = ""
.FirstPage.CenterFooter.Text = ""
.FirstPage.RightFooter.Text = ""
End With
Application.PrintCommunication = True
.Name = GetSheetName(CopyRange, i)
With .PageSetup
.Zoom = False
'.FitToPagesWide = 1
' .FitToPagesTall = 1
End With
End With
Set CopyRange = Nothing
Next
.Activate
.Range("A1").Select
End With
Application.ScreenUpdating = True
Cells.Replace What:="f 0000 ", Replacement:="Заявка на выдачу товарно-материальных ценностей со склада № ГС-", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
ReplaceFormat:=False, FormulaVersion:=xlReplaceFormula2
' Range("A1").Select
' Application.CutCopyMode = False
' Selection.Copy
End Sub
Private Function GetSheetName(iRng As Range, n)
Dim rngAct As Range 'Как Диапазон
Dim iTmp
On Error Resume Next
Set rngAct = iRng.Find(What:="0000", LookIn:=xlValues, LookAt:=xlPart)
If Not rngAct Is Nothing Then
iTmp = Split(rngAct.value, " ") ' я хочу Расщеплять
GetSheetName = iTmp(0) & "_" & iTmp(2) & "_(" & n & ")"
End If
End Function
Sub DelSheets()
Dim iSh As Worksheet 'Тусклый, как рабочий лист
Application.DisplayAlerts = False 'Отображаемые сообщения
For Each iSh In Worksheets 'Для каждого Из Них В Рабочих Листах
If iSh.Name Like "0000**" Then iSh.Delete 'Если это так.Имя типа "0000*", То это так.Удалить
Next
Application.DisplayAlerts = True
End Sub
Sub Del()
End Sub
Option Explicit
'v2
Sub ОТЧЕТЗаменить_шапку_и_подписантов()
Sheets("Лист1").Select
ActiveWindow.View = xlNormalView
Dim rHeader As Range, rPodpis As Range
Set rHeader = Sheets("Лист1").Range("A1:K7")
Set rPodpis = Sheets("Лист1").Range("A27:H31")
rHeader.Interior.Color = RGB(255, 255, 255)
rPodpis.Interior.Color = RGB(255, 255, 255)
ReplaceSheet Sheets("TDSheet"), rHeader, rPodpis
End Sub
Private Sub ReplaceSheet(Sh As Worksheet, rHeader As Range, rPodpis As Range)
Sh.Select
ReplaceHeader Sh, rHeader
ReplacePodpis Sh, rPodpis
Sh.PageSetup.PrintArea = Sh.UsedRange.Address(1, 1, xlA1)
End Sub
Private Sub ReplaceHeader(Sh As Worksheet, rHeader As Range)
With Sh
Dim ys As Long, ye As Long, rt As Range
For ys = .UsedRange.Row To .UsedRange.Row + .UsedRange.Rows.Count - 1
If .Cells(ys, 1).MergeArea.Columns.Count > 1 Then
If Left(.Cells(ys, 1).value, 3) = "ОТЧ" Then
If ys > 2 Then
Set rt = .Cells(ys - 2, 1) '.End(xlUp)
'If Not IsEmpty(rt.Value) Then Set rt = rt.Cells(2, 1)
' Set rt = rt.Resize(, .Cells(ys, 1).MergeArea.Columns.Count)
' Set rt = .Range(rt, .Cells(ys, 1).MergeArea.Offset(-2))
Set rt = rt.Resize(rHeader.Rows.Count, rHeader.Columns.Count)
rt.Select
rt.Clear
rHeader.Copy
' ActiveSheet.Pictures.Paste(Link:=True).Select
ActiveSheet.Paste
Application.CutCopyMode = False
End If
End If
End If
Next
Application.CutCopyMode = False
End With
End Sub
Private Sub ReplacePodpis(Sh As Worksheet, rPodpis As Range)
With Sh
Dim ys As Long, ye As Long, ii As Long, rt As Range, pc As Object
For ys = .UsedRange.Row To .UsedRange.Row + .UsedRange.Rows.Count - 1
If .Cells(ys, 1).MergeArea.Columns.Count > 1 Then
If Left(.Cells(ys, 1).value, Len("Проверил")) = "Проверил" Then
For ye = ys + 1 To .UsedRange.Row + .UsedRange.Rows.Count - 1
If Left(.Cells(ye, 1).value, Len("Барило С. М.")) = "Барило С. М." Then Exit For
Next
Set rt = .Range(.Cells(ys, 1), .Cells(ye, 1))
rt.Select
rt.EntireRow.Clear
On Error Resume Next
rt.EntireRow.UnMerge
On Error GoTo 0
ii = 0
Do
If ii > 20 Then Exit Do
If rt.Rows.Count >= rPodpis.Rows.Count Then Exit Do
rt.Rows(2).EntireRow.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
ii = ii + 1
DoEvents
Loop
For ii = 1 To rt.Rows.Count
rt.Rows(ii).EntireRow.RowHeight = rPodpis.Rows(ii).EntireRow.RowHeight
Next
rPodpis.Copy
'ActiveSheet.Pictures.Paste(Link:=True).Select
Set pc = ActiveSheet.Pictures.Paste(Link:=True)
Application.CutCopyMode = False
' ii = 0
' Do
' If ii > 20 Then Exit Do
' If pc.BottomRightCell.Row <= rt.Row + rt.Rows.Count Then Exit Do
' rt.Rows(3).EntireRow.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
' ii = ii + 1
' DoEvents
' Loop
End If
End If
Next
Application.CutCopyMode = False
End With
End Sub |
