Поиск  Пользователи  Правила  Войти
Форумы "Планета Excel" » Пользователи » Felixandr
Выбрать дату в календаре…Выбрать дату в календаре

Страницы: 1 2 След.
Макрос для сохранения выделенной области в JPG c присвоением имени из ячейки
 
#
29.06.2017 00:02:14
СПАСИБО за строчку. Автоматическое создание папки так и не осилил. Да и бог с ним. Работает кое как и на этом хорошо.
P/S Возник вопрос по серьёзнее, что-бы весь документ сохранялся в pdf, но тут уж точно нужно быть гуру, чтоб такое замутить!
Изменено: Felixandr - 29.06.2017 00:03:50
 
Перейти    
Макрос для сохранения выделенной области в JPG c присвоением имени из ячейки
 
#
28.06.2017 15:22:20
Цитата
Юрий М написал:
Причём тут ПАПКА?
Цитата
Felixandr написал:
а нужно, что бы в папке где и файл создалась своя папка "ОТЧЕТЫ"
 
Перейти    
Макрос для сохранения выделенной области в JPG c присвоением имени из ячейки
 
#
28.06.2017 15:18:55
Проблема в том что папка должна создаваться в папке с файлом ,так как для разных компьютеров этот путь будет разным.
 
Перейти    
Макрос для сохранения выделенной области в JPG c присвоением имени из ячейки
 
#
28.06.2017 14:43:05
Данный макрос сохраняет выделенный диапазон в картинку.
Но картинка сохраняется там же, где и документ, а нужно там же , но в своей собственной папке "Отчеты".
И еще нужно, чтобы название картинки бралось из ячейки документа
Код
Sub Range_to_Picture()
    Dim sName As String, wsTmpSh As Worksheet
    If TypeName(Selection) <> "Range" Then
        MsgBox "Выделенная область не является диапазоном!", vbCritical, "www.excel-vba.ru"
        Exit Sub
    End If
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    With Selection
        .CopyPicture
        Set wsTmpSh = ThisWorkbook.Sheets.Add
        sName = ActiveWorkbook.FullName & "_" & ActiveSheet.Name & "_Range"
        With wsTmpSh.ChartObjects.Add(0, 0, .Width, .Height).Chart
            .ChartArea.Border.LineStyle = 0
            .Parent.Select
            .Paste
            .Export Filename:=sName & ".gif", FilterName:="GIF"
            .Parent.Delete
        End With
    End With
    wsTmpSh.Delete
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
End Sub
Изменено: Felixandr - 28.06.2017 15:47:54
 
Перейти    
Макрос для сохранения выделенной области в JPG c присвоением имени из ячейки
 
#
28.06.2017 14:11:35
Если есть возможность реализовать, то интересует такой хитрый Макрос для сохранения выделенной области в png или jpg в папку с названием "отчеты", а название файла брал из указанной ему ячейки.
P/s максимум что мне удалось сделать это копировать выделенную область в буфер обмена, а дальше через paint и.т.д .
Хотелось бы автоматизировать процесс
Код
Sub Макрос8()
'
' Макрос8 Макрос
'

'
    Range("A2:D20").Select
    Range("D20").Activate
    Selection.CopyPicture Appearance:=xlScreen, Format:=xlBitmap
End Sub
Изменено: Felixandr - 28.06.2017 14:18:08
 
Перейти    
Таблица в "полнейший экран", Есть ли возможность развернуть документ в полный экран.
 
#
27.04.2017 17:13:17
По задумке, это должно происходить только с конкретным документом,
а в нём как раз есть отдельно нарисованная кнопка выход.
Ну а в крайнем случае, возврат по кнопке эскейп , например.
Изменено: Felixandr - 27.04.2017 17:14:37
 
Перейти    
Таблица в "полнейший экран", Есть ли возможность развернуть документ в полный экран.
 
#
27.04.2017 15:46:43
Судя по моему первому скриншоту, не сложно догадаться, что галки итак все убраны.
Автоскрытие панели задач, проявляет ее при наведении мыши,тем самым перекрывая  документ.
Вопрос остаётся открытым.  
При запуске любой игры - она раскрывается во весь полноценный экран автоматически,
закрывая собой и панель задач и всё остальное.
Тоже самого я хочу добиться и в экселе. Хотя не уверен, что это возможно.
Изменено: Felixandr - 27.04.2017 15:54:44
 
Перейти    
Таблица в "полнейший экран", Есть ли возможность развернуть документ в полный экран.
 
#
27.04.2017 14:57:41
Собственно говоря, интересует возможность открыть документ во весь экран. (без панели задач и верхнего трея)
Изменено: Felixandr - 28.04.2017 03:04:07
 
Перейти    
2 макроса (один прячет ячейки, другой возвращает) на одну кнопку
 
#
26.04.2017 13:23:28
Огромное спасибо за помощь. Просто тут единственный толковый форум, где вопросы решаются. А по поводу
Цитата
The_Prist написал:
Вы просто не хотите их пробовать и обдумать, видимо.
- это не так. Я очень хочу и пробовать и думать, но делаю это по мере своих сил, т.к совсем недавно в excel я умел только выводить документы на печать.
Ещё раз - Спасибо, что помогли!
 
Перейти    
2 макроса (один прячет ячейки, другой возвращает) на одну кнопку
 
#
26.04.2017 12:48:18
У меня кнопка убирает или добавляет сразу на 3-х листах и как использовать тот пример я ,увы, не знаю. Был бы макрос у меня простой, то и пример тот я бы подставил под него, а так...
 
Перейти    
2 макроса (один прячет ячейки, другой возвращает) на одну кнопку
 
#
26.04.2017 12:25:20
Скорее всего тут обычный подход поможет.
Изменено: Felixandr - 26.04.2017 12:50:57
 
Перейти    
2 макроса (один прячет ячейки, другой возвращает) на одну кнопку
 
#
26.04.2017 12:10:16
Имеется 2 макроса (один убирает ячейки, другой возвращает). В данный момент они у меня назначены на 2 разных кнопки.
Как их назначить на одну кнопку, чтобы при нажатии, в зависимости от ситуации, кнопка выполняла макрос первый либо второй.
Код
Sub УбНИЗ()
'
' УбНИЗ Макрос
'
    Application.ScreenUpdating = False
'
    Sheets("Раунд2").Select
    Sheets("Раунд2").Unprotect Password:="1148"
    Rows("21:36").RowHeight = 0
    Rows("20:20").RowHeight = 0.75
    Range("J3:K3").Select
    Sheets("Раунд2").Protect Password:="1148"
    Sheets("Раунд3").Select
    Sheets("Раунд3").Unprotect Password:="1148"
    Rows("21:36").RowHeight = 0
    Rows("20:20").RowHeight = 0.75
    Range("J3:K3").Select
    Sheets("Раунд3").Protect Password:="1148"
    Sheets("Раунд1").Select
    Sheets("Раунд1").Unprotect Password:="1148"
    Rows("21:36").RowHeight = 0
    Rows("20:20").RowHeight = 0.75
    Range("J3:K3").Select
    Sheets("Раунд1").Protect Password:="1148"
    Application.ScreenUpdating = True
End Sub

Sub ДобНИЗ()
'
' ДобНИЗ Макрос
'
    Application.ScreenUpdating = False
    Sheets("Раунд2").Select
    Sheets("Раунд2").Unprotect Password:="1148"
    Rows("20:21").RowHeight = 18
    Rows("31:31").RowHeight = 22.5
    Rows("32:36").RowHeight = 21.75
    Range("J3:K3").Select
    Sheets("Раунд2").Protect Password:="1148"
    Sheets("Раунд3").Select
    Sheets("Раунд3").Unprotect Password:="1148"
    Rows("20:21").RowHeight = 18
    Rows("31:31").RowHeight = 22.5
    Rows("32:36").RowHeight = 21.75
    Range("J3:K3").Select
    Sheets("Раунд3").Protect Password:="1148"
    Sheets("Раунд1").Select
    Sheets("Раунд1").Unprotect Password:="1148"
    Rows("20:21").RowHeight = 18
    Rows("31:31").RowHeight = 22.5
    Rows("32:36").RowHeight = 21.75
    Range("J3:K3").Select
    Sheets("Раунд1").Protect Password:="1148"
    Application.ScreenUpdating = True
End Sub
Изменено: Felixandr - 26.04.2017 12:30:38
 
Перейти    
Запрет ввода определенных цифр, При запрете ввода числа "1" остальные числа начинающиеся на единицу не вводятся
 
#
22.04.2017 21:18:23
Цитата
AAF написал:
позже...
Буду ждать с нетерпением
 
Перейти    
Запрет ввода определенных цифр, При запрете ввода числа "1" остальные числа начинающиеся на единицу не вводятся
 
#
22.04.2017 19:14:53
Чуть шуба не завернулась. И все равно не работает как надо
 
Перейти    
Запрет ввода определенных цифр, При запрете ввода числа "1" остальные числа начинающиеся на единицу не вводятся
 
#
22.04.2017 18:26:58
Цитата
AAF написал:
Ее просто в модуль листа.
Неа , при переходе на другую ячейку ни убирает
 
Перейти    
Запрет ввода определенных цифр, При запрете ввода числа "1" остальные числа начинающиеся на единицу не вводятся
 
#
22.04.2017 18:22:58
Потому что я 3 недели назад даже не знал как 2+2 в экселе сложить, а потом уже менять что-то было жалко - глядя на проделанную работу
Весь геморой из-за экранной клавиатуры, т.к с физической всё работало и без дополнительных макросов.
Я даже больше скажу, если бы я мог заставить sendkeys вводить знаки не заменяя предыдущих, то и макросы проверок бы не понадобились
Изменено: Felixandr - 22.04.2017 18:25:22
 
Перейти    
Запрет ввода определенных цифр, При запрете ввода числа "1" остальные числа начинающиеся на единицу не вводятся
 
#
22.04.2017 18:18:05
Цитата
AAF написал:
Если подсветка и я перешел на другую ячейку без метелки, то примечания удалятся.
Не получается . В какую строку нужно вставить
 
Перейти    
Запрет ввода определенных цифр, При запрете ввода числа "1" остальные числа начинающиеся на единицу не вводятся
 
#
22.04.2017 18:14:49
С клавой у меня уже игра была готова полностью  (Покер)
А вот допилить под сенсор еще прийдется.
 
Перейти    
Запрет ввода определенных цифр, При запрете ввода числа "1" остальные числа начинающиеся на единицу не вводятся
 
#
22.04.2017 18:08:11
Варианты у меня на 3 листах. А с клавы нельзя ибо планшет на винде
 
Перейти    
Запрет ввода определенных цифр, При запрете ввода числа "1" остальные числа начинающиеся на единицу не вводятся
 
#
22.04.2017 18:05:46
Огромнейшее спасибо. Всё работает. Сейчас предстоит громадный кусок работы.

А что дает тот кусочек, который подкинуть не мешало бы?
Изменено: Felixandr - 22.04.2017 18:07:07
 
Перейти    
Запрет ввода определенных цифр, При запрете ввода числа "1" остальные числа начинающиеся на единицу не вводятся
 
#
22.04.2017 17:53:36
Вот так не хочет -
Код
Private Sub Worksheet_Change(ByVal Target As Range)
Sheets("Раунд1").Unprotect Password:="1148"
Dim a, iStr As Integer, i As Integer
  If Not Intersect(Target, Range("J14, L14, AF14, AH14")) Is Nothing Then
    a = Array(0, 7, 8, 9, 11, 12, 13, 14, 15, 16, 17, 18, 19, 20, 21, 22, 23, 24, 26, 27, 28, 30, 32, 34, 36, 38, 40, 42, 44, 46, 48, 52, 54, 56)
    If Target.Cells(1) <> "" Then
      Application.EnableEvents = False
      If Not Target.Comment Is Nothing Then Target = CInt(Target.Comment.Text & Target)
      For i = LBound(a) To UBound(a)
        If Target = a(i) Then Exit For
        If iStr <> 1 Then iStr = InStr(1, a(i), Target)
      Next
      If i > UBound(a) Then
        If iStr = 1 Then
          If Target.Comment Is Nothing Then
            Target.AddComment
            With Target.Comment
              .Visible = True
              .Shape.Top = Target.Top - Target.Height
              .Shape.Left = Target.Left
              .Shape.Width = Target.Width
              .Shape.Height = Target.Height
            End With
          End If
          Target.Comment.Text CStr(Target.Value)
          Target = ""
        Else
          If Not Target.Comment Is Nothing Then Target.Comment.Delete
          Target = ""
        End If
      Else
        If Not Target.Comment Is Nothing Then Target.Comment.Delete
      End If
    End If
  End If
  Application.EnableEvents = True
Sheets("Раунд1").Protect Password:="1148"
Sheets("Раунд1").Unprotect Password:="1148"
Dim a, iStr As Integer, i As Integer
  If Not Intersect(Target, Range("J13, L13, AF13, AH13")) Is Nothing Then
    a = Array(0, 2, 3, 4, 6, 8, 9, 10, 11, 12, 13, 14, 15, 16, 17, 18, 19, 20, 21, 22, 23, 24, 26, 27, 28, 30, 32, 34, 36, 38, 40, 42, 44, 46, 48, 50, 52, 54, 56, 60, 70, 80, 90, 100, 120, 140, 160, 180, 200)
    If Target.Cells(1) <> "" Then
      Application.EnableEvents = False
      If Not Target.Comment Is Nothing Then Target = CInt(Target.Comment.Text & Target)
      For i = LBound(a) To UBound(a)
        If Target = a(i) Then Exit For
        If iStr <> 1 Then iStr = InStr(1, a(i), Target)
      Next
      If i > UBound(a) Then
        If iStr = 1 Then
          If Target.Comment Is Nothing Then
            Target.AddComment
            With Target.Comment
              .Visible = True
              .Shape.Top = Target.Top - Target.Height
              .Shape.Left = Target.Left
              .Shape.Width = Target.Width
              .Shape.Height = Target.Height
            End With
          End If
          Target.Comment.Text CStr(Target.Value)
          Target = ""
        Else
          If Not Target.Comment Is Nothing Then Target.Comment.Delete
          Target = ""
        End If
      Else
        If Not Target.Comment Is Nothing Then Target.Comment.Delete
      End If
    End If
  End If
  Application.EnableEvents = True
Sheets("Раунд1").Protect Password:="1148"
End Sub
 
Перейти    
Запрет ввода определенных цифр, При запрете ввода числа "1" остальные числа начинающиеся на единицу не вводятся
 
#
22.04.2017 17:45:05
Но меняя те 2 строки
Код
  If Not Intersect(Target, Range("J14, L14, AF14, AH14")) Is Nothing Then
    a = Array(0, 7, 8, 9, 11, 12, 13, 14, 15, 16, 17, 18, 19, 20, 21, 22, 23, 24, 26, 27, 28, 30, 32, 34, 36, 38, 40, 42, 44, 46, 48, 52, 54, 56)
на вот эти 2 строки
Код
If Not Intersect(Target, Range("J13, L13, AF13, AH13")) Is Nothing Then
    a = Array(0, 2, 3, 4, 6, 8, 9, 10, 11, 12, 13, 14, 15, 16, 17, 18, 19, 20, 21, 22, 23, 24, 26, 27, 28, 30, 32, 34, 36, 38, 40, 42, 44, 46, 48, 50, 52, 54, 56, 60, 70, 80, 90, 100, 120, 140, 160, 180, 200)
оно пишет Dublicate declaration in current score
 
Перейти    
Запрет ввода определенных цифр, При запрете ввода числа "1" остальные числа начинающиеся на единицу не вводятся
 
#
22.04.2017 17:41:03
Вот так теперь выглядит рабочая формула
Код
Private Sub Worksheet_Change(ByVal Target As Range)
Sheets("Раунд1").Unprotect Password:="1148"
Dim a, iStr As Integer, i As Integer
  If Not Intersect(Target, Range("J14, L14, AF14, AH14")) Is Nothing Then
    a = Array(0, 7, 8, 9, 11, 12, 13, 14, 15, 16, 17, 18, 19, 20, 21, 22, 23, 24, 26, 27, 28, 30, 32, 34, 36, 38, 40, 42, 44, 46, 48, 52, 54, 56)
    If Target.Cells(1) <> "" Then
      Application.EnableEvents = False
      If Not Target.Comment Is Nothing Then Target = CInt(Target.Comment.Text & Target)
      For i = LBound(a) To UBound(a)
        If Target = a(i) Then Exit For
        If iStr <> 1 Then iStr = InStr(1, a(i), Target)
      Next
      If i > UBound(a) Then
        If iStr = 1 Then
          If Target.Comment Is Nothing Then
            Target.AddComment
            With Target.Comment
              .Visible = True
              .Shape.Top = Target.Top - Target.Height
              .Shape.Left = Target.Left
              .Shape.Width = Target.Width
              .Shape.Height = Target.Height
            End With
          End If
          Target.Comment.Text CStr(Target.Value)
          Target = ""
        Else
          If Not Target.Comment Is Nothing Then Target.Comment.Delete
          Target = ""
        End If
      Else
        If Not Target.Comment Is Nothing Then Target.Comment.Delete
      End If
    End If
  End If
  Application.EnableEvents = True
Sheets("Раунд1").Protect Password:="1148"
End Sub
 
Перейти    
Запрет ввода определенных цифр, При запрете ввода числа "1" остальные числа начинающиеся на единицу не вводятся
 
#
22.04.2017 17:37:02
Какие переменные еще нужно менять для остальных строк? Просто я заменил  вот эти на другие данные и оно написало Dublicate declaration in current score
Код
  If Not Intersect(Target, Range("J14, L14, AF14, AH14")) Is Nothing Then
    a = Array(0, 7, 8, 9, 11, 12, 13, 14, 15, 16, 17, 18, 19, 20, 21, 22, 23, 24, 26, 27, 28, 30, 32, 34, 36, 38, 40, 42, 44, 46, 48, 52, 54, 56)
Изменено: Felixandr - 22.04.2017 17:39:24
 
Перейти    
Запрет ввода определенных цифр, При запрете ввода числа "1" остальные числа начинающиеся на единицу не вводятся
 
#
22.04.2017 17:34:04
ВЫ КУДЕСНИК!
 
Перейти    
Запрет ввода определенных цифр, При запрете ввода числа "1" остальные числа начинающиеся на единицу не вводятся
 
#
22.04.2017 17:29:46
А если ошибся - введет заново.  
 
Перейти    
Запрет ввода определенных цифр, При запрете ввода числа "1" остальные числа начинающиеся на единицу не вводятся
 
#
22.04.2017 17:20:33
А как снять подсвечивание? (тогда и метелка не понадобится)
 
Перейти    
Запрет ввода определенных цифр, При запрете ввода числа "1" остальные числа начинающиеся на единицу не вводятся
 
#
22.04.2017 17:10:07
Та же ошибка
 
Перейти    
Запрет ввода определенных цифр, При запрете ввода числа "1" остальные числа начинающиеся на единицу не вводятся
 
#
22.04.2017 17:03:43
C защитой отлично заработало.   С метелкой ошибка выскакивает - run-time error 424  Object required
 
Перейти    
Запрет ввода определенных цифр, При запрете ввода числа "1" остальные числа начинающиеся на единицу не вводятся
 
#
22.04.2017 16:50:10
Код
Sub METELKA()
'
    Application.ScreenUpdating = False
    Application.EnableEvents = False ' Добавлено

'
Selection.ClearContents
Application.ScreenUpdating = True
Application.EnableEvents = True ' Добавлено
If Not Target.Comment Is Nothing Then Target.Comment.Delete
End Sub
ТАК?
 
Перейти    
Страницы: 1 2 След.
Наверх