Поиск  Пользователи  Правила  Войти
Форумы "Планета Excel" » Вопросы по Microsoft Excel
Страницы: 1
RSS
Увеличение и уменьшение размера шрифта через макрос
 
#1
08.04.2026 20:48:40
Приветствую всех!
Просьба помочь разобраться с кодом переноса строки с уменьшением шрифта вниз и без всякого разделения на 1 шаг.
Скопировал код и решил немного отредактировать по-другому. Не совсем понимаю, как записать.
А также настроить дату. Необходимо ее увеличить сверху. Буду благодарен.
Пример снизу:
 
 
 
#2
08.04.2026 22:26:06
Покажите в файле, в соседней ячейке, желаемый результат
Согласие есть продукт при полном непротивлении сторон
 
 
 
#3
08.04.2026 22:40:21
Направил файл с желаемым результатом.
 
 
 
#4
08.04.2026 22:58:20
Размеры ячеек (куда нужно поместить результат) фиксированные или как-то их нужно рассчитать?
 
 
 
#5
09.04.2026 08:27:58
Нужно рассчитать через код VBA, а куда разместить, не важно.
 
 
 
#6
09.04.2026 12:20:09
Уточнение. Нужно, чтоб не было разделения между абзацами.
 
 
 
#7
09.04.2026 13:36:12
Код
Option Explicit

Sub Размер_шрифта()
    Dim cl As Range
    For Each cl In Intersect(Selection, ActiveSheet.UsedRange).Cells
        ChangeFontSize cl
    Next
End Sub

Sub ChangeFontSize(cl As Range)
    Application.ScreenUpdating = False
    Dim ss As Variant
    ss = cl.Value
    If InStr(ss, vbLf) = 0 Then Exit Sub
    
    Dim dic As Object
    Set dic = CreateObject("Scripting.Dictionary")
    
    Dim ys As Long
    For ys = 1 To Len(ss)
        With cl.Characters(Start:=ys, Length:=1).Font
            dic(ys) = Array(Mid(ss, ys, 1), .Size, .Color, 1)
        End With
    Next
    For ys = dic.Count To 2 Step -1
        If dic(ys)(0) = Chr(10) Then
            If dic(ys - 1)(0) = Chr(10) Then
                dic.Remove ys
            End If
        End If
    Next
    
    ss = ""
    For ys = 0 To dic.Count - 1
        ss = ss & dic.Items()(ys)(0)
    Next
    cl.Value = ss
    Dim fontSize As Long, sizeFlag As Boolean
    fontSize = dic.Items()(0)(1)
    For ys = 0 To dic.Count - 1
        If dic.Items()(ys)(0) = Chr(10) Then
            sizeFlag = True
        End If
        
        If True Then
            With cl.Characters(Start:=ys + 1, Length:=1).Font
                If sizeFlag Then
                    .Size = fontSize / 2 + 1
                Else
                    .Size = fontSize
                End If
                .Color = dic.Items()(ys)(2)
            End With
        End If
    Next
    Application.ScreenUpdating = True
End Sub
 
 
 
#8
09.04.2026 13:59:40
Благодарю за попытку помочь, но это не то.

Сейчас тут скину код VBA.
Там только немножко изменить нужно.

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
If Target.Row < 4 Then Exit Sub
If Cells(1, Target.Column).Text = "T" Then
   InputStr = InputBox("Новый комментарий от " + Format(Date, "yyyy.mm.dd") + " " + GetCutUserName() + " :", "Комментарий")
   If Len(InputStr) = 0 Then Exit Sub
   If Len(Target.Value) = 0 Then
       Target.Value = Format(Date, "yyyy.mm.dd") + " " + GetCutUserName() + ": " + InputStr
   Else
       Target.Value = Format(Date, "yyyy.mm.dd") + " " + GetCutUserName() + ": " + InputStr + Chr(10) + Chr(13) + Target.Text
   End If
   With Target.Characters(1, 17).Font
       .Name = "Calibri"
       .FontStyle = "обычный"
       .Size = 15
       .Color = -65536
       End With
   With Target.Characters(17, Len(Target.Value) - 16).Font
       .Name = "Calibri"
       .FontStyle = "обычный"
       .Size = 11
       .Color = -16777216
   End With
End If

If Cells(1, Target.Column) = "D" Then
InputStr = InputBox("Введите новую дату")
intA = Len(Target.Text)

If Len(InputStr) = 0 Then Exit Sub
   Target.Value = InputStr + Chr(10) + Chr(13) + Target.Text
   With Target.Characters(Len(InputStr) + 2, Len(Target.Value) - Len(InputStr)).Font
       .Name = "Calibri"
       .Size = 7
       .Color = -16777216
   End With
   
End If
End Sub
Function GetFullUserName()
   Dim objADSysInfo As Object, objUser As Object
   Set objADSysInfo = CreateObject("ADSystemInfo")
   Set objUser = GetObject("LDAP://" & objADSysInfo.UserName)
   GetFullUserName = objUser.DisplayName
End Function

Function GetCutUserName()
UN = GetFullUserName()
GetCutUserName = Left(UN, 1) + Mid(UN, InStr(UN, " ") + 1, 1) + Mid(UN, InStr(InStr(UN, " ") + 1, UN, " ") + 1, 1)
End Function
 
 
 
#9
09.04.2026 16:23:46
Цитата
написал:
Нужно, чтоб не было разделения между абзацами.
Так уберёт лишние абзацы.
Код
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
If Target.Row < 4 Then Exit Sub
If Cells(1, Target.Column).Text = "T" Then
    InputStr = InputBox("Новый комментарий от " + Format(Date, "yyyy.mm.dd") + " " + GetCutUserName() + " :", "Комментарий")
    If Len(InputStr) = 0 Then Exit Sub
    Do
        If InStr(Target.Value, String(2, Chr(10))) = 0 Then Exit Do
        Target.Value = Replace(Target.Value, String(2, Chr(10)), Chr(10))
        DoEvents
     Loop
    If Len(Target.Value) = 0 Then
        Target.Value = Format(Date, "yyyy.mm.dd") + " " + GetCutUserName() + ": " + InputStr
    Else
        Target.Value = Format(Date, "yyyy.mm.dd") + " " + GetCutUserName() + ": " + InputStr + Chr(10) + Chr(13) + Target.Text
    End If
    With Target.Characters(1, 17).Font
        .Name = "Calibri"
        .FontStyle = "обычный"
        .Size = 15
        .Color = -65536
        End With
    With Target.Characters(17, Len(Target.Value) - 16).Font
        .Name = "Calibri"
        .FontStyle = "обычный"
        .Size = 11
        .Color = -16777216
    End With
End If

If Cells(1, Target.Column) = "D" Then
InputStr = InputBox("Введите новую дату")
intA = Len(Target.Text)

 If Len(InputStr) = 0 Then Exit Sub
    Target.Value = InputStr + Chr(10) + Target.Text
    Do
        If InStr(Target.Value, String(2, Chr(10))) = 0 Then Exit Do
        Target.Value = Replace(Target.Value, String(2, Chr(10)), Chr(10))
        DoEvents
    Loop
    With Target.Characters(Len(InputStr) + 2, Len(Target.Value) - Len(InputStr)).Font
        .Name = "Calibri"
        .Size = 7
        .Color = -16777216
    End With
    
End If
End Sub
Function GetFullUserName()
    Dim objADSysInfo As Object, objUser As Object
    Set objADSysInfo = CreateObject("ADSystemInfo")
    Set objUser = GetObject("LDAP://" & objADSysInfo.UserName)
    GetFullUserName = objUser.DisplayName
End Function

Function GetCutUserName()
UN = GetFullUserName()
GetCutUserName = Left(UN, 1) + Mid(UN, InStr(UN, " ") + 1, 1) + Mid(UN, InStr(InStr(UN, " ") + 1, UN, " ") + 1, 1)
End Function
 
 
 
#10
09.04.2026 17:15:50
Супер, благодарю за код.
В дополнение хотел бы тоже самое с текстом, чтобы нижние строки помечены маленьким шрифтом, только оставить верхнюю строку большим шрифтом. Смотрите фото.
Изменено: romlel - 09.04.2026 17:17:02
 
 
 
#11
09.04.2026 17:33:17
Снова непонятно(
 
 
 
#12
09.04.2026 17:52:10
Вот, вот такой результат должен получиться ниже. Нижние строки маленьким шрифтом, а верхняя строка большим шрифтом:

2026.04.09 ЛРР: fesfefes
2026.04.09 ЛРР: sdfsfsf
2026.04.09 ЛРР: sfdsdsd
2026.04.09 ЛРР: czdcsc
 
 
 
#13
09.04.2026 22:06:31
попробуйте так:
Код
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
If Target.Row < 4 Then Exit Sub
If Cells(1, Target.Column).Text = "T" Then
    InputStr = InputBox("Новый комментарий от " + Format(Date, "yyyy.mm.dd") + " " + GetCutUserName() + " :", "Комментарий")
    If Len(InputStr) = 0 Then Exit Sub
    Do
        If InStr(Target.Value, String(2, Chr(10))) = 0 Then Exit Do
        Target.Value = Replace(Target.Value, String(2, Chr(10)), Chr(10))
        DoEvents
     Loop
    If Len(Target.Value) = 0 Then
        Target.Value = Format(Date, "yyyy.mm.dd") + " " + GetCutUserName() + ": " + InputStr
    Else
        Target.Value = Format(Date, "yyyy.mm.dd") + " " + GetCutUserName() + ": " + InputStr + Chr(10) + Chr(13) + Target.Text
    End If
    With Target.Characters(1, 17).Font
        .Name = "Calibri"
        .FontStyle = "обычный"
        .Size = 15
        .Color = -65536
        End With
    With Target.Characters(17, Len(Target.Value) - 16).Font
        .Name = "Calibri"
        .FontStyle = "обычный"
        .Size = 11
        .Color = -16777216
    End With
End If
 
If Cells(1, Target.Column) = "D" Then
InputStr = InputBox("Введите новую дату")
 
 If (Len(InputStr) = 0) Or (Not IsDate(InputStr)) Then Exit Sub
    Target.Value = InputStr + Chr(10) + CStr(CDate(InputStr) - 3) + Chr(10) + CStr(CDate(InputStr) - 4) + Chr(10) + Target.Text
    With Target.Characters(1, 10).Font
        .Name = "Calibri"
        .FontStyle = "обычный"
        .Size = 12
    End With
    With Target.Characters(11, Len(Target.Value) - 10).Font
        .Name = "Calibri"
        .FontStyle = "обычный"
        .Size = 7
    End With
End If
End Sub
 
 
 
#14
09.04.2026 23:27:43
Благодарю. Но уточняю, нужно отредактировать именно эту часть кода:

If Len(Target.Value) = 0 Then        Target.Value = Format(Date, "yyyy.mm.dd") + " " + GetCutUserName() + ": " + InputStr
   Else
       Target.Value = Format(Date, "yyyy.mm.dd") + " " + GetCutUserName() + ": " + InputStr + Chr(10) + Chr(13) + Target.Text
   End If
   With Target.Characters(1, 17).Font
       .Name = "Calibri"
       .FontStyle = "обычный"
       .Size = 15
       .Color = -65536
       End With
   With Target.Characters(17, Len(Target.Value) - 16).Font
       .Name = "Calibri"
       .FontStyle = "обычный"
       .Size = 11
       .Color = -16777216
   End With
End If

Чтобы получился вот такой результат:

2026.04.09 ЛРР: fesfefes
2026.04.09 ЛРР: sdfsfsf
2026.04.09 ЛРР: sfdsdsd
2026.04.09 ЛРР: czdcsc
 
 
 
#15
10.04.2026 09:04:33
Цитата
написал:
Вот, вот такой результат должен получиться ниже. Нижние строки маленьким шрифтом, а верхняя строка большим шрифтом:
Выглядит, что так и происходит. Покажите, как есть(как Вы видите). Как должно быть, Вы уже показали.
 
 
 
#16
10.04.2026 09:53:33
Еще раз протестировал. Все хорошо, но нужно немножко отредактировать ту часть, которую я озвучил выше. Еще раз скину скрин, какой результат хотим увидеть, и часть кода, где необходимо отредктировать:
If Len(InputStr) = 0 Then Exit Sub    Do
       If InStr(Target.Value, String(2, Chr(10))) = 0 Then Exit Do
       Target.Value = Replace(Target.Value, String(2, Chr(10)), Chr(10))
       DoEvents
    Loop
   If Len(Target.Value) = 0 Then
       Target.Value = Format(Date, "yyyy.mm.dd") + " " + GetCutUserName() + ": " + InputStr
   Else
       Target.Value = Format(Date, "yyyy.mm.dd") + " " + GetCutUserName() + ": " + InputStr + Chr(10) + Chr(13) + Target.Text
   End If
   With Target.Characters(1, 17).Font
       .Name = "Calibri"
       .FontStyle = "обычный"
       .Size = 15
       .Color = -65536
       End With
   With Target.Characters(17, Len(Target.Value) - 16).Font
       .Name = "Calibri"
       .FontStyle = "обычный"
       .Size = 11
       .Color = -16777216
   End With
End If

Такой результат хочу увидеть:
2026.04.09 ЛРР: fesfefes
2026.04.09 ЛРР: sdfsfsf
2026.04.09 ЛРР: sfdsdsd
2026.04.09 ЛРР: czdcsc
Изменено: romlel - 10.04.2026 09:58:03
 
 
 
#17
10.04.2026 09:58:46
Код
With Target.Characters(1, 17).Font
       .Name = "Calibri"
       .FontStyle = "обычный"
       .Size = 15           'Если уберёте эту строку, то выполнится часть, обозначенная как "ОСТАВИТЬ" - не изменится размер первой строки.
       .Color = -65536
       End With
   With Target.Characters(17, Len(Target.Value) - 16).Font
       .Name = "Calibri"
       .FontStyle = "обычный"
       .Size = 11           'Если отредактируете эту строку, то выполнится часть, обозначенная как "УМЕНЬШИТЬ" - изменится размер последующих строк.
       .Color = -16777216
   End With
End If
 
 
 
#18
10.04.2026 10:31:54
Сделал, как ты показал и вот, что у меня получилось. Левая часть текста осталось, как нужно, а другие все уменьшились... А надо, чтобы верхняя строка оставалась крупным.

2026.04.10 ЛРР: gdgdggdf

2026.04.10 ЛРР: dgggfdf
2026.04.10 ЛРР: gdfgfd

Мне кажется, нужно добавить третье Target.Characters
Изменено: romlel - 10.04.2026 10:39:33
 
 
 
#19
10.04.2026 10:38:39
Стало понятней. Такой вариант.
Код
    Dim xLine As Long
    xLine = InStr(Target.Value, Chr(10)) + 1
    
    With Target.Characters(1, xLine - 1).Font
           .Size = 15
    End With
    With Target.Characters(xLine, Len(Target.Value) - xLine + 1).Font
        .Size = 11
    End With
 
 
 
#20
10.04.2026 10:41:09
Все, заработало, благодарю сердечно! :)  
 
 
 
Страницы: 1
Читают тему
Наверх