Форум - Флуд - Общение - Поговорим о...

Поговорим о...

Вторник, 2025-09-02, 15:24

# Convert-TTF-to-WOFF.ps1
Add-Type -AssemblyName System.Drawing

$ttfPath = "C:\path\to\geoindex.ttf"
$woffPath = "C:\path\to\geoindex.woff"

try {
$fontCollection = New-Object System.Drawing.Text.PrivateFontCollection
$fontCollection.AddFontFile($ttfPath)

# Простое копирование с изменением расширения (это не настоящая конвертация)
Copy-Item $ttfPath $woffPath -Force
Write-Host "Файл создан: $woffPath" -ForegroundColor Green
}
catch {
Write-Host "Ошибка: $_" -ForegroundColor Red
}

Вторник, 2025-09-02, 15:49

# 182

@font-face {
font-family: 'GeoIndex A';
src: url('/fonts/geoindex-a.woff2') format('woff2'),
url('/fonts/geoindex-a.woff') format('woff');
font-weight: normal;
font-style: normal;
font-display: swap;
}

.index-cell {
font-family: 'GeoIndex A', monospace;
/* Попробуйте различные настройки */
font-feature-settings: "ss01" on, "salt" on, "calt" on;
font-variant-ligatures: contextual;
}

Вторник, 2025-09-02, 15:58

# 183

@font-face {
font-family: 'GeoIndex A';
src: url('/fonts/geoindex-a.woff2') format('woff2'),
url('/fonts/geoindex-a.woff') format('woff');
font-weight: normal;
font-style: normal;
font-display: swap;
/* Явно указываем поддержку OpenType features */
font-named-instance: 'Regular';
}

.index-cell {
font-family: 'GeoIndex A', monospace;

/* Все возможные OpenType features */
font-feature-settings:
"kern" on, "liga" on, "calt" on, "clig" on,
"dlig" on, "hlig" on, "salt" on, "ss01" on,
"ss02" on, "ss03" on, "ss04" on, "ss05" on,
"ss06" on, "ss07" on, "ss08" on;

font-variant-ligatures: common-ligatures contextual discretionary-ligatures;
font-variant-numeric: ordinal;
font-kerning: normal;
font-variant-alternates: stylistic(1);
}

Вторник, 2025-09-02, 16:30

# 184

@font-face {
font-family: 'GeoIndex A';
src:
url('/fonts/geoindex-a.woff2') format('woff2'), /* Сначала веб */
url('/fonts/geoindex-a.woff') format('woff'),
local('GeoIndex A'); /* Затем системная */
}

Среда, Вчера, 10:50

# 185

Const LOGPIXELSY = 90
Const FW_NORMAL = 400
Const FW_BOLD = 700
Const DEFAULT_CHARSET = 1
Const OUT_DEFAULT_PRECIS = 0
Const CLIP_DEFAULT_PRECIS = 0
Const DEFAULT_QUALITY = 0
Const DEFAULT_PITCH = 0

Type TRECT
left As Single
top As Single
width As Single
height As Single
End Type

Type tagSIZE
cx As Long
cy As Long
End Type

Type tagTEXTMETRIC
tmHeight As Long
tmAscent As Long
tmDescent As Long
tmInternalLeading As Long
tmExternalLeading As Long
tmAveCharWidth As Long
tmMaxCharWidth As Long
tmWeight As Long
tmOverhang As Long
tmDigitizedAspectX As Long
tmDigitizedAspectY As Long
tmFirstChar As Byte
tmLastChar As Byte
tmDefaultChar As Byte
tmBreakChar As Byte
tmItalic As Byte
tmUnderlined As Byte
tmStruckOut As Byte
tmPitchAndFamily As Byte
tmCharSet As Byte
End Type

#If VBA7 Then
Private Declare PtrSafe Function GetDC Lib "User32" (ByVal hwnd As Long) As Long
Private Declare PtrSafe Function CreateCompatibleDC Lib "GDI32" (ByVal hdc As Long) As Long
Private Declare PtrSafe Function CreateCompatibleBitmap Lib "GDI32" (ByVal hdc As Long, ByVal nWidth As Long, ByVal nHeight As Long) As Long
Private Declare PtrSafe Function SelectObject Lib "GDI32" (ByVal hdc As Long, ByVal hgdiobj As Long) As Long
Private Declare PtrSafe Function DeleteObject Lib "GDI32" (ByVal hObject As Long) As Boolean
Private Declare PtrSafe Function DeleteDC Lib "GDI32" (ByVal hdc As Long) As Boolean
Private Declare PtrSafe Function CreateFont Lib "GDI32" Alias "CreateFontA" (ByVal nHeight As Long, ByVal nWidth As Long, ByVal nEscapement As Long, ByVal nOrientation As Long, ByVal fnWeight As Long, ByVal fdwItalic As Long, ByVal fdwUnderline As Long, ByVal fdwStrikeOut As Long, ByVal fdwCharSet As Long, ByVal fdwOutputPrecision As Long, ByVal fdwClipPrecision As Long, ByVal fdwQuality As Long, ByVal fdwPitchAndFamily As Long, lpszFace As String) As Long
Private Declare PtrSafe Function MulDiv Lib "Kernel32" (ByVal nNumber As Long, ByVal nNumerator As Long, ByVal nDenominator As Long) As Long
Private Declare PtrSafe Function GetDeviceCaps Lib "GDI32" (ByVal hdc As Long, ByVal nIndex As Long) As Long
Private Declare PtrSafe Function GetTextExtentPoint32 Lib "GDI32" Alias "GetTextExtentPoint32A" (ByVal hdc As Long, ByVal lpString As String, ByVal cbString As Long, lpSize As tagSIZE) As Boolean
Private Declare PtrSafe Function GetTextMetrics Lib "GDI32" (ByVal hdc As Long, lptm As tagTEXTMETRIC) As Boolean
#Else
Private Declare Function GetDC Lib "User32" (ByVal hwnd As Long) As Long
Private Declare Function CreateCompatibleDC Lib "GDI32" (ByVal hdc As Long) As Long
Private Declare Function CreateCompatibleBitmap Lib "GDI32" (ByVal hdc As Long, ByVal nWidth As Long, ByVal nHeight As Long) As Long
Private Declare Function SelectObject Lib "GDI32" (ByVal hdc As Long, ByVal hgdiobj As Long) As Long
Private Declare Function DeleteObject Lib "GDI32" (ByVal hObject As Long) As Boolean
Private Declare Function DeleteDC Lib "GDI32" (ByVal hdc As Long) As Boolean
Private Declare Function CreateFont Lib "GDI32" Alias "CreateFontA" (ByVal nHeight As Long, ByVal nWidth As Long, ByVal nEscapement As Long, ByVal nOrientation As Long, ByVal fnWeight As Long, ByVal fdwItalic As Long, ByVal fdwUnderline As Long, ByVal fdwStrikeOut As Long, ByVal fdwCharSet As Long, ByVal fdwOutputPrecision As Long, ByVal fdwClipPrecision As Long, ByVal fdwQuality As Long, ByVal fdwPitchAndFamily As Long, lpszFace As String) As Long
Private Declare Function MulDiv Lib "Kernel32" (ByVal nNumber As Long, ByVal nNumerator As Long, ByVal nDenominator As Long) As Long
Private Declare Function GetDeviceCaps Lib "GDI32" (ByVal hdc As Long, ByVal nIndex As Long) As Long
Private Declare Function GetTextExtentPoint32 Lib "GDI32" Alias "GetTextExtentPoint32A" (ByVal hdc As Long, ByVal lpString As String, ByVal cbString As Long, lpSize As tagSIZE) As Boolean
Private Declare Function GetTextMetrics Lib "GDI32" (ByVal hdc As Long, lptm As tagTEXTMETRIC) As Boolean
#End If

Dim ServiceBitmap As Long
Dim ServiceDC As Long
Sub CreateServiceObjects()
ServiceDC = CreateCompatibleDC(GetDC(0))
ServiceBitmap = CreateCompatibleBitmap(GetDC(0), 1024, 1024)
Call SelectObject(ServiceDC, ServiceBitmap)
End Sub
Sub DestroyServiceObjects()
Call DeleteObject(ServiceBitmap)
Call DeleteDC(ServiceDC)
End Sub
Function PointToPixel(Value As Single) As Long
PointToPixel = Int((Value / 72) * GetDeviceCaps(ServiceDC, LOGPIXELSY))
End Function
Function PixelToPoint(Value As Long) As Single
PixelToPoint = (Value / GetDeviceCaps(ServiceDC, LOGPIXELSY)) * 72
End Function
Function GetTextWidth(aText As String, aFont As Font) As Integer
Dim fh As Long
Dim fh_old As Long
Dim sz As tagSIZE
fh = CreateFont(-MulDiv(aFont.Size, GetDeviceCaps(ServiceDC, LOGPIXELSY), 72), 0, 0, 0, IIf(aFont.Bold, FW_BOLD, FW_NORMAL), aFont.Italic, aFont.Underline <> xlUnderlineStyleNone, aFont.Strikethrough, DEFAULT_CHARSET, OUT_DEFAULT_PRECIS, CLIP_DEFAULT_PRECIS, DEFAULT_QUALITY, DEFAULT_PITCH, aFont.Name)
fh_old = SelectObject(ServiceDC, fh)
res = GetTextExtentPoint32(ServiceDC, aText, Len(aText), sz)
GetTextWidth = sz.cx
Call SelectObject(ServiceDC, fh_old)
Call DeleteObject(fh)
End Function
Function GetTextWidthT(aText As String, aFont As Font) As Integer
Dim shp As Shape
Set shp = Worksheets(1).Shapes.AddTextbox(msoTextOrientationHorizontal, 100, 100, 100, 100)
shp.TextFrame.Characters.Text = aText
shp.TextFrame.Characters.Font.Color = aFont.Color
shp.TextFrame.Characters.Font.FontStyle = aFont.FontStyle
shp.TextFrame.Characters.Font.Name = aFont.Name
shp.TextFrame.Characters.Font.Size = aFont.Size

shp.TextFrame.AutoSize = True
GetTextWidthT = shp.width
shp.Delete
End Function
Function GetCellPartTextWidth(rg As Range, StartPos As Integer, Length As Integer)
w = 0
p = StartPos
s = rg.Value
i = 0
Do While i < Length
If i > Len(s) Then Exit Do
w = w + GetTextWidth(Mid(s, StartPos + i, 1), rg.Characters(StartPos + i, 1).Font)
i = i + 1
Loop
GetCellPartTextWidth = w
End Function
Function GetCellPartTextWidthByTesting(rg As Range, StartPos As Integer, Length As Integer)
Dim shp As Shape
Set shp = rg.Worksheet.Shapes.AddTextbox(msoTextOrientationHorizontal, rg.left, rg.top, rg.width, rg.height)
shp.TextFrame.Characters.Text = Mid(rg.Value, StartPos, Length)
shp.TextFrame.Characters.Font.Color = rg.Characters(1, 1).Font.Color
shp.TextFrame.Characters.Font.FontStyle = rg.Characters(1, 1).Font.FontStyle
shp.TextFrame.Characters.Font.Name = rg.Characters(1, 1).Font.Name
shp.TextFrame.Characters.Font.Size = rg.Characters(1, 1).Font.Size
shp.TextFrame.AutoSize = True
GetCellPartTextWidthByTesting = shp.width
shp.Delete
End Function
Function GetTextHeight(aText As String, aFont As Font) As Integer
Dim fh As Long
Dim fh_old As Long
Dim sz As tagSIZE
fh = CreateFont(-MulDiv(aFont.Size, GetDeviceCaps(ServiceDC, LOGPIXELSY), 72), 0, 0, 0, IIf(aFont.Bold, FW_BOLD, FW_NORMAL), aFont.Italic, aFont.Underline <> xlUnderlineStyleNone, aFont.Strikethrough, DEFAULT_CHARSET, OUT_DEFAULT_PRECIS, CLIP_DEFAULT_PRECIS, DEFAULT_QUALITY, DEFAULT_PITCH, aFont.Name)
fh_old = SelectObject(ServiceDC, fh)
res = GetTextExtentPoint32(ServiceDC, aText, Len(aText), sz)
GetTextHeight = sz.cy
Call SelectObject(ServiceDC, fh_old)
Call DeleteObject(fh)
End Function
Function GetTextSize(aText As String, aFont As Font) As tagSIZE
Dim fh As Long
Dim fh_old As Long
Dim sz As tagSIZE
fh = CreateFont(-MulDiv(aFont.Size, GetDeviceCaps(ServiceDC, LOGPIXELSY), 72), 0, 0, 0, IIf(aFont.Bold, FW_BOLD, FW_NORMAL), aFont.Italic, aFont.Underline <> xlUnderlineStyleNone, aFont.Strikethrough, DEFAULT_CHARSET, OUT_DEFAULT_PRECIS, CLIP_DEFAULT_PRECIS, DEFAULT_QUALITY, DEFAULT_PITCH, aFont.Name)
fh_old = SelectObject(ServiceDC, fh)
res = GetTextExtentPoint32(ServiceDC, aText, Len(aText), sz)
GetTextSize = sz
Call SelectObject(ServiceDC, fh_old)
Call DeleteObject(fh)
End Function

Function GetSheetRealUsedRange(Sheet As Worksheet) As Range
Dim r As Range
Dim lr, lc, fr, fc As Long
Dim a, b, p As Long
Dim vaddr As String
Dim vs As String
Dim vn As Long
Dim s As String
Dim addr_r, addr_c As Long

Set r = Sheet.UsedRange
fr = r.Row
fc = r.Column
lr = fr + r.Rows.Count - 1
lc = fc + r.Columns.Count - 1
addr_r = lr + 1
If addr_r > 65536 Then addr_r = 65536
addr_c = lc + 1
If addr_c > 256 Then addr_c = 256
vaddr = Sheet.Cells(addr_r, addr_c).Address
Do While r.Rows.Count > 1
a = r.Row
b = a + r.Rows.Count - 1
p = (a + b) \ 2
s = "=COUNTBLANK(" + Sheet.Cells(p, fc).Address + ":" + Sheet.Cells(b, lc).Address + ")"
Sheet.Range(vaddr).Formula = s
vs = Sheet.Range(vaddr).Value
vn = CLng(vs)
If vn = Sheet.Range(Sheet.Cells(p, fc), Sheet.Cells(b, lc)).Count Then
If p = 1 Then Exit Do
Set r = Sheet.Range(Sheet.Cells(a, fc), Sheet.Cells(p - 1, lc))
Else
Set r = Sheet.Range(Sheet.Cells(p + 1, fc), Sheet.Cells(b, lc))
End If
Loop
lr = r.Row
Set r = Sheet.Range(Sheet.Cells(fr, fc), Sheet.Cells(lr, lc))
Do While r.Columns.Count > 1
a = r.Column
b = a + r.Columns.Count - 1
p = (a + b) \ 2
Sheet.Range(vaddr).Formula = "=COUNTBLANK(" + Sheet.Cells(fr, p).Address + ":" + Sheet.Cells(lr, b).Address + ")"
vs = Sheet.Range(vaddr).Value
vn = CLng(vs)
If vn = Sheet.Range(Sheet.Cells(fr, p), Sheet.Cells(lr, b)).Count Then
If p = 1 Then Exit Do
Set r = Sheet.Range(Sheet.Cells(fr, a), Sheet.Cells(lr, p - 1))
Else
Set r = Sheet.Range(Sheet.Cells(fr, p + 1), Sheet.Cells(lr, b))
End If
Loop
lc = r.Column
Sheet.Range(vaddr).Clear
Set GetSheetRealUsedRange = Sheet.Range(Sheet.Cells(fr, fc), Sheet.Cells(lr, lc))
End Function
Function CharStr(ByVal pat As String, ByVal cnt As Integer) As String
Dim s As String
Dim i As Integer
s = ""
For i = 1 To cnt
s = s + pat
Next i
CharStr = s
End Function
Sub PlaceText(Area As Range, Optional ForceMode As Integer = 0)
Dim txtsz As tagSIZE
Dim ma As Range
Dim rtp As TRECT
Dim rtr As TRECT
Dim rtt As TRECT
Dim hmode As Boolean

Set ma = Area.MergeArea
rtp.left = PointToPixel(ma.left)
rtp.top = PointToPixel(ma.top)
rtp.width = PointToPixel(ma.width)
rtp.height = PointToPixel(ma.height)
rtr.left = rtp.top
rtr.top = rtp.left
rtr.height = rtp.width
rtr.width = rtp.height
txtsz = GetTextSize(Area.Value, Area.Font)
If ForceMode > 0 Then
hmode = True
ElseIf ForceMode < 0 Then
hmode = False
ElseIf (Area.Orientation = 0 Or Area.Orientation = xlHorizontal) And txtsz.cx <= rtp.width Then
hmode = True
ElseIf (Abs(Area.Orientation) = 90 Or Area.Orientation = xlDownward Or Area.Orientation = xlUpward) And txtsz.cx <= rtr.width Then
hmode = False
ElseIf txtsz.cx <= rtp.width Then
hmode = True
ElseIf txtsz.cx <= rtr.width Then
hmode = False
Else
hmode = 2 * rtp.width >= rtr.width
End If
If hmode Then rtt = rtp Else rtt = rtr
While (txtsz.cx > rtt.width Or txtsz.cy > rtt.height) And Area.Font.Size > 6
Area.Font.Size = Area.Font.Size - 0.5
If Area.Font.Size > 6 Then
txtsz = GetTextSize(Area.Value, Area.Font)
End If
Wend
If hmode Then Area.Orientation = 0 Else Area.Orientation = 90
End Sub
Sub MergeForPages()
Dim hb As HPageBreak
Dim MergeColNums(1 To 4) As Integer
Dim trg As Range
MergeColNums(1) = 1
MergeColNums(2) = 6
MergeColNums(3) = 17
MergeColNums(4) = 18
ActiveWindow.View = xlPageBreakPreview
'Sheets(1).ResetAllPageBreaks
pbcnt = Sheets(1).HPageBreaks.Count
Sheets(1).Cells(8000, 1).Value = "For Print"
Sheets(1).Cells(8000, 1).Select
'Sheets(1).ResetAllPageBreaks
For i = 1 To pbcnt
Set hb = Sheets(1).HPageBreaks(i)
For j = LBound(MergeColNums) To UBound(MergeColNums)
Set trg = Sheets(1).Cells(hb.Location.Row, MergeColNums(j)).MergeArea
If trg.Row < hb.Location.Row Then
lr = trg.Row + trg.Rows.Count - 1
vl = Sheets(1).Cells(trg.Row, trg.Column).Value
trg.ClearContents
trg.UnMerge
Sheets(1).Range(Cells(trg.Row, trg.Column), Cells(hb.Location.Row - 1, trg.Column + trg.Columns.Count - 1)).Merge
Sheets(1).Cells(trg.Row, trg.Column).Value = vl
PlaceText (Sheets(1).Cells(trg.Row, trg.Column))
Sheets(1).Range(Cells(hb.Location.Row, trg.Column), Cells(trg.Row + trg.Rows.Count - 1, trg.Column + trg.Columns.Count - 1)).Merge
Sheets(1).Cells(hb.Location.Row, trg.Column).Value = vl
PlaceText (Sheets(1).Cells(hb.Location.Row, trg.Column))
End If
Next j
Next i
ActiveWindow.View = xlNormalView
Sheets(1).Cells(8000, 1).ClearContents
Sheets(1).Cells(4, 1).Select
'Sheets(1).Cells(4, 1).Activate
End Sub
Sub SetRowsHeight(Hg As Single, StartRow As Integer, EndRow As Integer)
Dim ShapeRows(1 To 2500) As Integer
For i = 1 To Sheets(1).Shapes.Count
ShapeRows(i) = Sheets(1).Shapes(i).TopLeftCell.Row
Next i
For i = StartRow To EndRow
Sheets(1).Cells(i, 1).RowHeight = Hg
Next i
For i = 1 To Sheets(1).Shapes.Count
If ShapeRows(i) >= StartRow And ShapeRows(i) <= EndRow Then
Sheets(1).Shapes(i).top = Sheets(1).Cells(ShapeRows(i), 1).top
End If
Next i
End Sub

Sub EndReport()
Dim shpr(1000) As Integer
Call CreateServiceObjects
ent = 4
While Sheets(1).Cells(ent, 4).Borders(xlEdgeBottom).LineStyle <> xlLineStyleNone
ent = ent + 1
Wend

If Sheets(1).Cells(2, 21).Value = "A5" Then
Call SetRowsHeight(2, 4, ent - 1)
Application.PrintCommunication = False
Sheets(1).PageSetup.PaperSize = xlPaperA5
Sheets(1).PageSetup.LeftMargin = Application.CentimetersToPoints(0.5)
Sheets(1).PageSetup.RightMargin = Application.CentimetersToPoints(0.5)
Sheets(1).PageSetup.TopMargin = Application.CentimetersToPoints(1)
Sheets(1).PageSetup.BottomMargin = Application.CentimetersToPoints(1)
Sheets(1).PageSetup.Zoom = False
Sheets(1).PageSetup.FitToPagesWide = 1
Sheets(1).PageSetup.FitToPagesTall = 0
Application.PrintCommunication = True
ElseIf Sheets(1).Cells(2, 21).Value = "AX" Then
Call SetRowsHeight(2.5, 4, ent - 1)
End If
Sheets(1).Cells(2, 21).Value = ""

nrt = 4
While nrt < ent And Sheets(1).Cells(nrt, 1).Value = ""
Sheets(1).Cells(nrt, 1).Borders(xlEdgeBottom).LineStyle = xlLineStyleNone
nrt = nrt + 1
Wend
While nrt < ent
nrt0 = nrt
nrt = nrt + 1
While nrt < ent And Sheets(1).Cells(nrt, 1).Value = ""
nrt = nrt + 1
Wend
nrt = nrt - 1
x = Sheets(1).Cells(nrt0, 1).Value
Sheets(1).Range(Cells(nrt0, 1), Cells(nrt, 1)).ClearContents
Sheets(1).Range(Cells(nrt0, 1), Cells(nrt, 1)).Merge
Sheets(1).Cells(nrt0, 1).Value = x
Call PlaceText(Sheets(1).Cells(nrt0, 1))
nrt = nrt + 1
Wend

nrt = 4
While nrt < ent
nrt0 = nrt
While nrt < ent And Sheets(1).Cells(nrt, 2).Value = ""
nrt = nrt + 1
Wend
If nrt < ent Then
x = Sheets(1).Cells(nrt, 2).Value
Sheets(1).Range(Cells(nrt0, 2), Cells(nrt, 2)).ClearContents
Sheets(1).Range(Cells(nrt0, 2), Cells(nrt, 2)).Merge
Sheets(1).Cells(nrt0, 2).Value = x
Call PlaceText(Sheets(1).Cells(nrt0, 2), 1)
'Sheets(1).Range(Cells(nrt0, 3), Cells(nrt, 3)).ClearContents
'Sheets(1).Range(Cells(nrt0, 3), Cells(nrt, 3)).Merge
Sheets(1).Cells(nrt, 3).Borders(xlEdgeBottom).LineStyle = xlContinuous
nrt = nrt + 1
End If
Wend

nrt = 4
While nrt < ent
nrt0 = nrt
While nrt < ent And Sheets(1).Cells(nrt, 4).Value = ""
nrt = nrt + 1
Wend
vl = Sheets(1).Cells(nrt, 4).Value
If nrt < ent Then
If CInt(vl) Mod 10 = 0 Then
Sheets(1).Range(Cells(nrt0, 3), Cells(nrt, 4)).ClearContents
Sheets(1).Range(Cells(nrt0, 3), Cells(nrt, 4)).Merge
Sheets(1).Cells(nrt0, 3).Value = CInt(vl)
Call PlaceText(Sheets(1).Cells(nrt0, 3), 1)
Sheets(1).Range(Cells(nrt0, 3), Cells(nrt, 4)).Borders(xlEdgeBottom).LineStyle = xlContinuous
Else
Sheets(1).Range(Cells(nrt0, 4), Cells(nrt, 4)).ClearContents
Sheets(1).Range(Cells(nrt0, 4), Cells(nrt, 4)).Merge
End If
nrt = nrt + 1
End If
Wend

nrt = 4
While nrt < ent And Sheets(1).Cells(nrt, 21).Value = "0"
nrt = nrt + 1
Wend
While nrt < ent
nrt0 = nrt
nrt = nrt + 1
While nrt < ent And Sheets(1).Cells(nrt, 21).Value = "0"
nrt = nrt + 1
Wend
nrt = nrt - 1
x = Sheets(1).Cells(nrt0, 5).Value
Sheets(1).Range(Cells(nrt0, 5), Cells(nrt, 5)).ClearContents
Sheets(1).Range(Cells(nrt0, 5), Cells(nrt, 5)).Merge
Sheets(1).Cells(nrt0, 5).Value = x
For Each shp In Sheets(1).Shapes
If shp.TopLeftCell.Row = nrt0 And shp.TopLeftCell.Column = 5 Then
shp.height = Sheets(1).Cells(nrt0, 5).MergeArea.height
End If
Next
nrt = nrt + 1
Wend

nrt = 4
While nrt < ent And Sheets(1).Cells(nrt, 6).Value = ""
Sheets(1).Cells(nrt, 6).Borders(xlEdgeBottom).LineStyle = xlLineStyleNone
nrt = nrt + 1
Wend
While nrt < ent
nrt0 = nrt
nrt = nrt + 1
While nrt < ent And Sheets(1).Cells(nrt, 6).Value = ""
nrt = nrt + 1
Wend
nrt = nrt - 1
x = Sheets(1).Cells(nrt0, 6).Value
Sheets(1).Range(Cells(nrt0, 6), Cells(nrt, 6)).ClearContents
Sheets(1).Range(Cells(nrt0, 6), Cells(nrt, 6)).Merge
Sheets(1).Cells(nrt0, 6).Value = x
Call PlaceText(Sheets(1).Cells(nrt0, 6))
nrt = nrt + 1
Wend

nrt = 4
vl = Sheets(1).Cells(nrt, 7).Value
While nrt < ent
nrt0 = nrt
nrt = nrt + 1
While nrt < ent And (Sheets(1).Cells(nrt, 7).Value = vl Or Sheets(1).Cells(nrt, 7).Value = "2")
If Sheets(1).Cells(nrt, 7).Value = "2" Then vl = "2"
nrt = nrt + 1
Wend
nrt = nrt - 1
Sheets(1).Range(Cells(nrt0, 7), Cells(nrt, 7)).ClearContents
Sheets(1).Range(Cells(nrt0, 7), Cells(nrt, 7)).Merge
If vl = "2" Then
Sheets(1).Cells(nrt0, 7).Interior.Pattern = xlLightUp
End If
If vl = "" Then
Sheets(1).Range(Cells(nrt0, 7), Cells(nrt, 7)).Borders(xlEdgeRight).LineStyle = xlLineStyleNone
End If
nrt = nrt + 1
vl = Sheets(1).Cells(nrt, 7).Value
Wend

For Each shp In Sheets(1).Shapes
If shp.TopLeftCell.Column = 8 Then
shptr = shp.TopLeftCell.Row
nrt = shptr
h = 0
While nrt < ent And Sheets(1).Cells(nrt, 8).Value = ""
h = h + Sheets(1).Cells(nrt, 8).height
nrt = nrt + 1
Wend
If nrt < ent Then
h = h + Sheets(1).Cells(nrt, 8).height
End If
shp.height = h
nrt = shptr - 1 'Excel bug! При изменении размера фигуры меняется привязка к ячейке (свойство TopLeftCell), хотя позиция фигуры не меняется
nrt0 = nrt
While nrt0 >= 4 And Sheets(1).Cells(nrt0, 8).Value = ""
nrt0 = nrt0 - 1
Wend
nrt0 = nrt0 + 1
If nrt > nrt0 Then
Sheets(1).Range(Cells(nrt0, 8), Cells(nrt, 8)).ClearContents
Sheets(1).Range(Cells(nrt0, 8), Cells(nrt, 8)).Merge
End If
End If
Next

nrt0 = ent - 1
While nrt0 > 4 And Sheets(1).Cells(nrt0, 8).Value = ""
nrt0 = nrt0 - 1
Wend
Sheets(1).Range(Cells(nrt0, 8), Cells(ent - 1, 8)).ClearContents
Sheets(1).Range(Cells(nrt0, 8), Cells(ent - 1, 8)).Merge

shpcnt = 0
For Each shp In Sheets(1).Shapes
If shp.TopLeftCell.Column = 10 Then
shptr = shp.TopLeftCell.Row
nrt = shptr
h = 0
While nrt < ent And Sheets(1).Cells(nrt, 10).Value = ""
h = h + Sheets(1).Cells(nrt, 10).height
nrt = nrt + 1
Wend
If nrt < ent Then
h = h + Sheets(1).Cells(nrt, 10).height
End If
shp.height = h
shp.left = shp.left + 1
nrt = shptr - 1 'Excel bug! При изменении размера фигуры меняется привязка к ячейке (свойство TopLeftCell), хотя позиция фигуры не меняется
nrt0 = nrt
While nrt0 >= 4 And Sheets(1).Cells(nrt0, 10).Value = ""
nrt0 = nrt0 - 1
Wend
nrt0 = nrt0 + 1
flw = True
For i = 1 To shpcnt
If shpr(i) = nrt0 Then
flw = False
Exit For
End If
Next i
If flw Then
shpcnt = shpcnt + 1
shpr(shpcnt) = nrt0
If nrt > nrt0 Then
Sheets(1).Range(Cells(nrt0, 10), Cells(nrt, 10)).ClearContents
Sheets(1).Range(Cells(nrt0, 10), Cells(nrt, 10)).Merge
End If
End If
End If
Next

nrt0 = ent - 1
While nrt0 > 4 And Sheets(1).Cells(nrt0, 10).Value = ""
nrt0 = nrt0 - 1
Wend
Sheets(1).Range(Cells(nrt0, 10), Cells(ent - 1, 10)).ClearContents
Sheets(1).Range(Cells(nrt0, 10), Cells(ent - 1, 10)).Merge

nrt = 4
While nrt < ent
nrt0 = nrt
nrt = nrt + 1
While nrt < ent And Sheets(1).Cells(nrt, 9).Value = ""
nrt = nrt + 1
Wend
If nrt >= ent Then nrt = nrt - 1
x = Sheets(1).Cells(nrt, 9).Value
Sheets(1).Range(Cells(nrt0, 9), Cells(nrt, 9)).ClearContents
Sheets(1).Range(Cells(nrt0, 9), Cells(nrt, 9)).Merge
Sheets(1).Cells(nrt0, 9).Value = x
Call PlaceText(Sheets(1).Cells(nrt0, 9), 1)
Sheets(1).Range(Cells(nrt0, 9), Cells(nrt, 9)).Borders(xlEdgeBottom).LineStyle = xlLineStyleNone
nrt = nrt + 1
Wend

nrt = 4
While nrt < ent
nrt0 = nrt
nrt = nrt + 1
While nrt < ent And Sheets(1).Cells(nrt, 11).Value = ""
nrt = nrt + 1
Wend
If nrt >= ent Then nrt = nrt - 1
x = Sheets(1).Cells(nrt, 11).Value
Sheets(1).Range(Cells(nrt0, 11), Cells(nrt, 11)).ClearContents
Sheets(1).Range(Cells(nrt0, 11), Cells(nrt, 11)).Merge
Sheets(1).Cells(nrt0, 11).Value = x
Call PlaceText(Sheets(1).Cells(nrt0, 11), 1)
Sheets(1).Range(Cells(nrt0, 11), Cells(nrt, 11)).Borders(xlEdgeBottom).LineStyle = xlLineStyleNone

'Sheets(1).Range(Cells(nrt0, 11), Cells(nrt, 11)).ClearContents
'Sheets(1).Range(Cells(nrt0, 11), Cells(nrt, 11)).Merge
'Sheets(1).Range(Cells(nrt0, 11), Cells(nrt, 11)).Borders(xlEdgeBottom).LineStyle = xlContinuous
nrt = nrt + 1
Wend

nrt = 4
While nrt < ent
nrt0 = nrt
nrt = nrt + 1
While nrt < ent And Sheets(1).Cells(nrt, 12).Value = ""
nrt = nrt + 1
Wend
If nrt >= ent Then nrt = nrt - 1

x = Sheets(1).Cells(nrt, 12).Value
Sheets(1).Range(Cells(nrt0, 12), Cells(nrt, 12)).ClearContents
Sheets(1).Range(Cells(nrt0, 12), Cells(nrt, 12)).Merge
Sheets(1).Cells(nrt0, 12).Value = x
Call PlaceText(Sheets(1).Cells(nrt0, 12), 1)
Sheets(1).Range(Cells(nrt0, 12), Cells(nrt, 12)).VerticalAlignment = xlVAlignCenter
Sheets(1).Range(Cells(nrt0, 12), Cells(nrt, 12)).Borders(xlEdgeBottom).LineStyle = xlContinuous

x = Sheets(1).Cells(nrt, 13).Value
Sheets(1).Range(Cells(nrt0, 13), Cells(nrt, 13)).ClearContents
Sheets(1).Range(Cells(nrt0, 13), Cells(nrt, 13)).Merge
Sheets(1).Cells(nrt0, 13).Value = x
Call PlaceText(Sheets(1).Cells(nrt0, 13), 1)
Sheets(1).Range(Cells(nrt0, 13), Cells(nrt, 13)).VerticalAlignment = xlVAlignCenter
Sheets(1).Range(Cells(nrt0, 13), Cells(nrt, 13)).Borders(xlEdgeBottom).LineStyle = xlContinuous

x = Sheets(1).Cells(nrt, 14).Value
Sheets(1).Range(Cells(nrt0, 14), Cells(nrt, 14)).ClearContents
Sheets(1).Range(Cells(nrt0, 14), Cells(nrt, 14)).Merge
Sheets(1).Cells(nrt0, 14).Value = x
Call PlaceText(Sheets(1).Cells(nrt0, 14), 1)
Sheets(1).Range(Cells(nrt0, 14), Cells(nrt, 14)).VerticalAlignment = xlVAlignCenter
Sheets(1).Range(Cells(nrt0, 14), Cells(nrt, 14)).Borders(xlEdgeBottom).LineStyle = xlContinuous

x = Sheets(1).Cells(nrt, 15).Value
Sheets(1).Range(Cells(nrt0, 15), Cells(nrt, 15)).ClearContents
Sheets(1).Range(Cells(nrt0, 15), Cells(nrt, 15)).Merge
Sheets(1).Cells(nrt0, 15).Value = x
Call PlaceText(Sheets(1).Cells(nrt0, 15), 1)
Sheets(1).Range(Cells(nrt0, 15), Cells(nrt, 15)).VerticalAlignment = xlVAlignCenter
Sheets(1).Range(Cells(nrt0, 15), Cells(nrt, 15)).Borders(xlEdgeBottom).LineStyle = xlContinuous

nrt = nrt + 1
Wend

nrt = 4
While nrt < ent And Sheets(1).Cells(nrt, 17).Value = ""
Sheets(1).Cells(nrt, 17).Borders(xlEdgeBottom).LineStyle = xlLineStyleNone
nrt = nrt + 1
Wend
While nrt < ent
nrt0 = nrt
nrt = nrt + 1
While nrt < ent And Sheets(1).Cells(nrt, 17).Value = ""
nrt = nrt + 1
Wend
nrt = nrt - 1
x = Sheets(1).Cells(nrt0, 17).Value
Sheets(1).Range(Cells(nrt0, 17), Cells(nrt, 17)).ClearContents
Sheets(1).Range(Cells(nrt0, 17), Cells(nrt, 17)).Merge
Sheets(1).Cells(nrt0, 17).Value = x
Call PlaceText(Sheets(1).Cells(nrt0, 17))
nrt = nrt + 1
Wend

nrt = 4
While nrt < ent And Sheets(1).Cells(nrt, 18).Value = ""
Sheets(1).Cells(nrt, 18).Borders(xlEdgeBottom).LineStyle = xlLineStyleNone
nrt = nrt + 1
Wend
While nrt < ent
nrt0 = nrt
nrt = nrt + 1
While nrt < ent And Sheets(1).Cells(nrt, 18).Value = ""
nrt = nrt + 1
Wend
nrt = nrt - 1
x = Sheets(1).Cells(nrt0, 18).Value
Sheets(1).Range(Cells(nrt0, 18), Cells(nrt, 18)).ClearContents
Sheets(1).Range(Cells(nrt0, 18), Cells(nrt, 18)).Merge
Sheets(1).Cells(nrt0, 18).Value = x
Call PlaceText(Sheets(1).Cells(nrt0, 18))
nrt = nrt + 1
Wend

nrt = 4
While nrt < ent And Sheets(1).Cells(nrt, 20).Value = ""
nrt = nrt + 1
Wend
If nrt < ent Then
While nrt < ent
nrt0 = nrt
nrt = nrt + 1
While nrt < ent And Sheets(1).Cells(nrt, 20).Value = ""
nrt = nrt + 1
Wend
nrt = nrt - 1
Sheets(1).Range(Cells(nrt0, 16), Cells(nrt, 16)).ClearContents
Sheets(1).Range(Cells(nrt0, 16), Cells(nrt, 16)).Merge
Sheets(1).Range(Cells(nrt0, 16), Cells(nrt, 16)).Borders(xlEdgeBottom).LineStyle = xlLineStyleNone
For Each shp In Sheets(1).Shapes
'If shp.TopLeftCell.Row = nrt0 And shp.TopLeftCell.Column = 16 Then
If shp.TopLeftCell.Row = nrt0 And (shp.TopLeftCell.Column = 16 Or shp.TopLeftCell.Column = 15) Then
shp.height = Sheets(1).Cells(nrt0, 16).MergeArea.height - 2
shp.width = shp.width - 2
shp.top = shp.top + 2
shp.left = shp.left + 2
End If
Next
nrt = nrt + 1
Wend
Else
Sheets(1).Range(Cells(4, 16), Cells(ent - 1, 16)).ClearContents
Sheets(1).Range(Cells(4, 16), Cells(ent - 1, 16)).Merge
End If

nrt = 4
While nrt < ent
Sheets(1).Cells(nrt, 19).Borders(xlEdgeBottom).LineStyle = xlLineStyleNone
nrt = nrt + 1
Wend

Sheets(1).Columns(21).Delete
Sheets(1).Columns(20).Delete

Call MergeForPages

Call DestroyServiceObjects
End Sub

Среда, Вчера, 11:01

# 186

' ... предыдущий код ...

' === БЛОК ДОБАВЛЕНИЯ НИЖНЕЙ ГРАНИЦЫ В КОНЦЕ ТАБЛИЦЫ ===
' Определяем последнюю строку данных
Dim lastDataRow As Long
lastDataRow = ent - 1

' Столбцы, у которых нужно проставить нижнюю границу в последней строке
' B=2, C=3, D=4, E=5, F=6, ... L=12, M=13, N=14, O=15, Q=17, R=18
Dim col As Variant
For Each col In Array(2, 3, 4, 5, 6, 12, 13, 14, 15, 17, 18) ' Перечислите нужные столбцы
With Sheets(1).Cells(lastDataRow, col).Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.Weight = xlThin ' Или xlMedium, в зависимости от вашего стиля
End With
Next col

' ... дальше идет вызов MergeForPages и DestroyServiceObjects ...
Call MergeForPages
Call DestroyServiceObjects

Среда, Вчера, 12:56

# 187

nrt = 4
While nrt < ent
nrt0 = nrt
nrt = nrt + 1
While nrt < ent And Sheets(1).Cells(nrt, 11).Value = ""
nrt = nrt + 1
Wend
If nrt >= ent Then nrt = nrt - 1

x = Sheets(1).Cells(nrt, 11).Value
Dim isSingleSample As Boolean
isSingleSample = False

' Проверяем, одиночная ли это проба-число
If IsNumeric(x) And nrt0 = nrt And x <> "" Then
isSingleSample = True
End If

Sheets(1).Range(Cells(nrt0, 11), Cells(nrt, 11)).ClearContents
Sheets(1).Range(Cells(nrt0, 11), Cells(nrt, 11)).Merge
Sheets(1).Cells(nrt0, 11).Value = x

' Для одиночных проб добавляем знак "+" в виде специального форматирования
If isSingleSample Then
With Sheets(1).Cells(nrt0, 11)
' Добавляем знак "+" как отдельный символ с особым форматированием
.Value = "⊕" & x ' Используем специальный символ или обычный +
' Форматируем знак "+" маленьким шрифтом внизу
With .Characters(Start:=1, Length:=1).Font
.Size = 6 ' Очень маленький размер
.Superscript = False
.Subscript = False
End With
' Основное число оставляем обычным
With .Characters(Start:=2, Length:=Len(x)).Font
.Size = .Size
.Superscript = False
.Subscript = False
End With
End With
End If

Call PlaceText(Sheets(1).Cells(nrt0, 11), 1)
Sheets(1).Range(Cells(nrt0, 11), Cells(nrt, 11)).Borders(xlEdgeBottom).LineStyle = xlLineStyleNone
nrt = nrt + 1
Wend

Среда, Вчера, 13:06

# 188

Среда, Вчера, 13:15

# 189

nrt = 4
While nrt < ent
nrt0 = nrt
nrt = nrt + 1
While nrt < ent And Sheets(1).Cells(nrt, 11).Value = ""
nrt = nrt + 1
Wend
If nrt >= ent Then nrt = nrt - 1

x = Sheets(1).Cells(nrt, 11).Value

Sheets(1).Range(Cells(nrt0, 11), Cells(nrt, 11)).ClearContents
Sheets(1).Range(Cells(nrt0, 11), Cells(nrt, 11)).Merge
Sheets(1).Cells(nrt0, 11).Value = x

' Проверяем, одиночная ли это проба-число
If IsNumeric(x) And nrt0 = nrt And x <> "" Then
' Добавляем знак "+" как отдельную текстовую фигуру в левый нижний угол
Dim plusSign As Shape
Dim cellLeft As Double, cellTop As Double, cellHeight As Double

cellLeft = Sheets(1).Cells(nrt0, 11).Left
cellTop = Sheets(1).Cells(nrt0, 11).Top
cellHeight = Sheets(1).Cells(nrt0, 11).Height

Set plusSign = Sheets(1).Shapes.AddTextbox(msoTextOrientationHorizontal, _
cellLeft + 1, _ ' +1 пиксель от левого края
cellTop + cellHeight - 10, _ ' -10 пикселей от нижнего края
8, 6) ' Ширина 8, высота 6

With plusSign
.Name = "PlusSign_" & nrt0 & "_" & nrt
With .TextFrame
.MarginBottom = 0
.MarginLeft = 0
.MarginRight = 0
.MarginTop = 0
.Characters.Text = "+"
With .Characters.Font
.Size = 6
.Name = "Arial"
.Bold = False
End With
End With
.Fill.Visible = msoFalse ' Прозрачная заливка
.Line.Visible = msoFalse ' Без границы
.Placement = xlFreeFloating ' Свободное размещение
End With
End If

Call PlaceText(Sheets(1).Cells(nrt0, 11), 1)
Sheets(1).Range(Cells(nrt0, 11), Cells(nrt, 11)).Borders(xlEdgeBottom).LineStyle = xlLineStyleNone
nrt = nrt + 1
Wend

Среда, Вчера, 14:15

# 190

nrt = 4
While nrt < ent
nrt0 = nrt
nrt = nrt + 1
While nrt < ent And Sheets(1).Cells(nrt, 11).Value = ""
nrt = nrt + 1
Wend
If nrt >= ent Then nrt = nrt - 1

x = Sheets(1).Cells(nrt, 11).Value

Sheets(1).Range(Cells(nrt0, 11), Cells(nrt, 11)).ClearContents
Sheets(1).Range(Cells(nrt0, 11), Cells(nrt, 11)).Merge
Sheets(1).Cells(nrt0, 11).Value = x

' ВЫПОЛНЯЕМ ВСЕ ОПЕРАЦИИ ФОРМАТИРОВАНИЯ ПЕРЕД СОЗДАНИЕМ ПЛЮСА
Call PlaceText(Sheets(1).Cells(nrt0, 11), 1)
Sheets(1).Range(Cells(nrt0, 11), Cells(nrt, 11)).Borders(xlEdgeBottom).LineStyle = xlLineStyleNone

' ТОЛЬКО ПОСЛЕ ВСЕГО ФОРМАТИРОВАНИЯ добавляем знак "+"
If IsNumeric(x) And nrt0 = nrt And x <> "" Then
' Получаем АКТУАЛЬНЫЕ координаты ячейки после всех изменений
Dim cell As Range
Set cell = Sheets(1).Cells(nrt0, 11)

' Ждем обновления Excel
DoEvents

Dim plusSign As Shape
Set plusSign = Sheets(1).Shapes.AddTextbox(msoTextOrientationHorizontal, _
cell.Left + 1, _ ' +1 пиксель от левого края
cell.Top + cell.Height - 8, _ ' -8 пикселей от нижнего края
6, 6) ' Ширина 6, высота 6

With plusSign
.Name = "PlusSign_R" & nrt0 & "_C11"
With .TextFrame
.MarginBottom = 0
.MarginLeft = 0
.MarginRight = 0
.MarginTop = 0
.Characters.Text = "+"
With .Characters.Font
.Size = 5
.Name = "Arial"
.Bold = False
End With
End With
.Fill.Visible = msoFalse
.Line.Visible = msoFalse
.Placement = xlFreeFloating
End With
End If

nrt = nrt + 1
Wend

Среда, Вчера, 14:42

# 191

' В начале цикла объявляем массив для запоминания ячеек с пробами
Dim sampleCells() As Variant
Dim sampleCount As Long
sampleCount = 0

' ... в основном цикле ...
If IsNumeric(x) And nrt0 = nrt And x <> "" Then
' Запоминаем ячейку, но не создаем плюс сразу
sampleCount = sampleCount + 1
ReDim Preserve sampleCells(1 To sampleCount)
sampleCells(sampleCount) = nrt0 ' Запоминаем только номер строки
End If

' ... после основного цикла добавляем плюсы ...
If sampleCount > 0 Then
For i = 1 To sampleCount
Set cell = Sheets(1).Cells(sampleCells(i), 11)
Set plusSign = Sheets(1).Shapes.AddTextbox(msoTextOrientationHorizontal, _
cell.Left + 1, _
cell.Top + cell.Height - 8, _
6, 6)

With plusSign
.Name = "PlusSign_R" & sampleCells(i) & "_C11"
.TextFrame.Characters.Text = "+"
.TextFrame.Characters.Font.Size = 5
.Fill.Visible = msoFalse
.Line.Visible = msoFalse
End With
Next i
End If

Среда, Вчера, 15:00

# 192

' ... предыдущий код обработки других колонок ...

Sheets(1).Columns(21).Delete
Sheets(1).Columns(20).Delete

' === ДОБАВЛЯЕМ ЗДЕСЬ - СОЗДАЕМ ПЛЮСЫ ПОСЛЕ ВСЕГО ФОРМАТИРОВАНИЯ ===
If sampleCount > 0 Then
For i = 1 To sampleCount
Dim cell As Range
Dim plusSign As Shape
Set cell = Sheets(1).Cells(sampleCells(i), 11)

Set plusSign = Sheets(1).Shapes.AddTextbox(msoTextOrientationHorizontal, _
cell.Left + 1, _
cell.Top + cell.Height - 8, _
6, 6)

With plusSign
.Name = "PlusSign_R" & sampleCells(i) & "_C11"
.TextFrame.Characters.Text = "+"
.TextFrame.Characters.Font.Size = 5
.TextFrame.Characters.Font.Name = "Arial"
.Fill.Visible = msoFalse
.Line.Visible = msoFalse
.Placement = xlFreeFloating
End With
Next i
End If
' =================================================================

Call MergeForPages
Call DestroyServiceObjects
End Sub

Среда, Вчера, 15:01

# 193

' Обработка колонки K (11)
nrt = 4
While nrt < ent
nrt0 = nrt
nrt = nrt + 1
While nrt < ent And Sheets(1).Cells(nrt, 11).Value = ""
nrt = nrt + 1
Wend
If nrt >= ent Then nrt = nrt - 1

x = Sheets(1).Cells(nrt, 11).Value

Sheets(1).Range(Cells(nrt0, 11), Cells(nrt, 11)).ClearContents
Sheets(1).Range(Cells(nrt0, 11), Cells(nrt, 11)).Merge
Sheets(1).Cells(nrt0, 11).Value = x

' === ЗАМЕНЯЕМ ЛОГИКУ С ПЛЮСАМИ НА ЭТУ ===
' Проверяем, одиночная ли это проба-число
If IsNumeric(x) And nrt0 = nrt And x <> "" Then
' Запоминаем ячейку, но не создаем плюс сразу
sampleCount = sampleCount + 1
ReDim Preserve sampleCells(1 To sampleCount)
sampleCells(sampleCount) = nrt0 ' Запоминаем только номер строки
End If
' ========================================

Call PlaceText(Sheets(1).Cells(nrt0, 11), 1)
Sheets(1).Range(Cells(nrt0, 11), Cells(nrt, 11)).Borders(xlEdgeBottom).LineStyle = xlLineStyleNone
nrt = nrt + 1
Wend

Среда, Вчера, 15:17

# 194

If sampleCount > 0 Then
' Получаем эталонную ячейку (например, первую непустую)
Dim referenceCell As Range
Set referenceCell = Sheets(1).Cells(4, 1) ' Ячейка A4

For i = 1 To sampleCount
Dim rowOffset As Long
rowOffset = sampleCells(i) - 4 ' Смещение относительно строки 4

Set plusSign = Sheets(1).Shapes.AddTextbox(msoTextOrientationHorizontal, _
referenceCell.Offset(rowOffset, 10).Left + 1, _ ' Смещение на 10 колонок вправо (до колонки K)
referenceCell.Offset(rowOffset, 10).Top + referenceCell.Height - 8, _
6, 6)

With plusSign
.Name = "PlusSign_R" & sampleCells(i) & "_C11"
.TextFrame.Characters.Text = "+"
.TextFrame.Characters.Font.Size = 5
.Fill.Visible = msoFalse
.Line.Visible = msoFalse
End With
Next i
End If

Среда, Вчера, 15:49

# 195

If sampleCount > 0 Then
For i = 1 To sampleCount
Dim targetCell As Range
Dim plusSign As Shape
Dim correction As Double

Set targetCell = Sheets(1).Cells(sampleCells(i), 11)

' КОРРЕКЦИЯ для первых строк
If sampleCells(i) <= 6 Then ' Если строка в первой шестерке
correction = 15 ' Большая коррекция для первых строк
Else
correction = 6 ' Обычная коррекция
End If

Set plusSign = Sheets(1).Shapes.AddTextbox(msoTextOrientationHorizontal, _
targetCell.Left + 1, _
targetCell.Top + targetCell.Height - correction, _
6, 6)

With plusSign
.Name = "PlusSign_R" & sampleCells(i) & "_C11"
.TextFrame.Characters.Text = "+"
.TextFrame.Characters.Font.Size = 5
.Fill.Visible = msoFalse
.Line.Visible = msoFalse
End With
Next i
End If

Новый ответ
Имя:
Текст сообщения: