Домашняя страница Undo Do New Save Карта сайта Обратная связь Поиск по форуму
МИР MS EXCEL - Гость.xls

Вход

Регистрация

Напомнить пароль

 

= Мир MS Excel/Перенос чисел из календаря на другой лист - Мир MS Excel

Старая форма входа
  • Страница 1 из 1
  • 1
Модератор форума: китин, _Boroda_  
Мир MS Excel » Вопросы и решения » Вопросы по VBA » Перенос чисел из календаря на другой лист (Макросы/Sub)
Перенос чисел из календаря на другой лист
tasdel Дата: Воскресенье, 29.03.2020, 18:10 | Сообщение № 1
Группа: Проверенные
Ранг: Форумчанин
Сообщений: 144
Репутация: 0 ±
Замечаний: 20% ±

Excel 2007
Здравствуйте уважаемые гуру этого форума!!!
Возникла проблема по переносу чисел (дат) из календаря вертикального типа, в календарь горизонтального типа находящегося на другом листе рабочей книги.
По русски говоря: не получилось у меня привязать один календарь к другому. Все перепробовал: "ВПР", "ПОИСК ПОЗИЦИИ", и т.д. не помогло...
Думаю без макроса тут не обойтись.
И еще маленький нюанс!!! Выходные дни на горизонтальном календаре должны заливаться серым цветом.
Прилагаю файл.
Заранее спасибо
К сообщению приложен файл: 2144190.xls (183.0 Kb)
 
Ответить
СообщениеЗдравствуйте уважаемые гуру этого форума!!!
Возникла проблема по переносу чисел (дат) из календаря вертикального типа, в календарь горизонтального типа находящегося на другом листе рабочей книги.
По русски говоря: не получилось у меня привязать один календарь к другому. Все перепробовал: "ВПР", "ПОИСК ПОЗИЦИИ", и т.д. не помогло...
Думаю без макроса тут не обойтись.
И еще маленький нюанс!!! Выходные дни на горизонтальном календаре должны заливаться серым цветом.
Прилагаю файл.
Заранее спасибо
Автор - tasdel
Дата добавления - 29.03.2020 в 18:10
gling Дата: Воскресенье, 29.03.2020, 21:06 | Сообщение № 2
Группа: Друзья
Ранг: Участник клуба
Сообщений: 2563
Репутация: 706 ±
Замечаний: 0% ±

2010
Цитата tasdel, 29.03.2020 в 18:10, в сообщении № 1 ()
проблема по переносу чисел (дат) из календаря вертикального типа, в календарь горизонтального

Здравствуйте. А зачем переносить, можно же создать горизонтальный на основе месяца и года на листе Календарь.
В файле вариант для Excel2007 и выше.
К сообщению приложен файл: 2245546.xls (44.0 Kb)

ЯД-41001506838083

Сообщение отредактировал gling - Воскресенье, 29.03.2020, 21:34
 
Ответить
Сообщение
Цитата tasdel, 29.03.2020 в 18:10, в сообщении № 1 ()
проблема по переносу чисел (дат) из календаря вертикального типа, в календарь горизонтального

Здравствуйте. А зачем переносить, можно же создать горизонтальный на основе месяца и года на листе Календарь.
В файле вариант для Excel2007 и выше.
Автор - gling
Дата добавления - 29.03.2020 в 21:06
tasdel Дата: Воскресенье, 29.03.2020, 21:43 | Сообщение № 3
Группа: Проверенные
Ранг: Форумчанин
Сообщений: 144
Репутация: 0 ±
Замечаний: 20% ±

Excel 2007
gling, Спасибо что откликнулись. Я все-таки написал код. Все работает, как я планировал. Утром наверное не с той ноги встал, поэтому туго соображалось.
Спасибо всем, тема закрыта!!!
 
Ответить
Сообщениеgling, Спасибо что откликнулись. Я все-таки написал код. Все работает, как я планировал. Утром наверное не с той ноги встал, поэтому туго соображалось.
Спасибо всем, тема закрыта!!!
Автор - tasdel
Дата добавления - 29.03.2020 в 21:43
Pelena Дата: Воскресенье, 29.03.2020, 21:46 | Сообщение № 4
Группа: Админы
Ранг: Местный житель
Сообщений: 19405
Репутация: 4555 ±
Замечаний: ±

Excel 365 & Mac Excel
tasdel, поделиться решением не хотите? Для последующих поколений)

"Черт возьми, Холмс! Но как??!!"
Ю-money 41001765434816
 
Ответить
Сообщениеtasdel, поделиться решением не хотите? Для последующих поколений)
Автор - Pelena
Дата добавления - 29.03.2020 в 21:46
Shylo Дата: Вторник, 31.03.2020, 13:02 | Сообщение № 5
Группа: Проверенные
Ранг: Форумчанин
Сообщений: 171
Репутация: 7 ±
Замечаний: 0% ±

Excel-2007; 2016
По варианту файла Владимира, у меня выделяло Пятницы и Субботы (в 2003 и 2007), сделал вариант УФ на Субботы и Воскресенья для 2003 и выше.
К сообщению приложен файл: ___.xls (44.0 Kb)
 
Ответить
СообщениеПо варианту файла Владимира, у меня выделяло Пятницы и Субботы (в 2003 и 2007), сделал вариант УФ на Субботы и Воскресенья для 2003 и выше.
Автор - Shylo
Дата добавления - 31.03.2020 в 13:02
tasdel Дата: Вторник, 31.03.2020, 17:25 | Сообщение № 6
Группа: Проверенные
Ранг: Форумчанин
Сообщений: 144
Репутация: 0 ±
Замечаний: 20% ±

Excel 2007
Pelena, Здравствуйте!!! Получилось так, что Вы написали мне сообщение после того, как я удалился из форума.
Я свой код уже зарядил в свою рабочую книгу, где уже очень много было нахимичено. Естественно я его уже завязал с основной рабочей кодовой процедурой.
Весь файл выложить не получиться, так как он превышает местный лимит по объему.Попытался выдернуть лист с макросом из книги, не получилось, т.к. ексель начал на меня ругаться. Я уже не стал влезать в дебри, выяснять причину ошибки. Могу выложить код - как есть, только уже с другими координатами.
 
Ответить
СообщениеPelena, Здравствуйте!!! Получилось так, что Вы написали мне сообщение после того, как я удалился из форума.
Я свой код уже зарядил в свою рабочую книгу, где уже очень много было нахимичено. Естественно я его уже завязал с основной рабочей кодовой процедурой.
Весь файл выложить не получиться, так как он превышает местный лимит по объему.Попытался выдернуть лист с макросом из книги, не получилось, т.к. ексель начал на меня ругаться. Я уже не стал влезать в дебри, выяснять причину ошибки. Могу выложить код - как есть, только уже с другими координатами.
Автор - tasdel
Дата добавления - 31.03.2020 в 17:25
tasdel Дата: Вторник, 31.03.2020, 17:26 | Сообщение № 7
Группа: Проверенные
Ранг: Форумчанин
Сообщений: 144
Репутация: 0 ±
Замечаний: 20% ±

Excel 2007
[vba]
Код
Sub КАЛЕНДАРЬ()
Application.ScreenUpdating = False

If Worksheets(7).Range("J34").Value <> 29 Then
Worksheets(3).Range("AF11").Value = ""
Else
Worksheets(3).Range("AF11").Value = 29
Worksheets(3).Range("AG11").Value = ""
Worksheets(3).Range("AH11").Value = ""
End If

If Worksheets(7).Range("J34").Value <> 30 Then
Worksheets(3).Range("AG11").Value = ""
Else
Worksheets(3).Range("AF11").Value = 29
Worksheets(3).Range("AG11").Value = 30
Worksheets(3).Range("AH11").Value = ""
End If

If Worksheets(7).Range("J34").Value <> 31 Then
Worksheets(3).Range("AH11").Value = ""
Else
Worksheets(3).Range("AF11").Value = 29
Worksheets(3).Range("AG11").Value = 30
Worksheets(3).Range("AH11").Value = 31
End If

Worksheets(3).Range("D11:AH11").Interior.ColorIndex = xlNone
Worksheets(4).Range("D11:AH11").Interior.ColorIndex = xlNone
Worksheets(5).Range("D11:AH11").Interior.ColorIndex = xlNone

n = 0
While Worksheets(3).Cells(n + 11, 4).Value <> ""
n = n + 1
Wend
For j = 4 To n + 30

If Worksheets(3).Cells(11, j) = Worksheets(7).Range("E40") Then
Worksheets(3).Cells(11, j).Interior.ColorIndex = 15
End If

If Worksheets(3).Cells(11, j) = Worksheets(7).Range("E41") Then
Worksheets(3).Cells(11, j).Interior.ColorIndex = 15
End If

If Worksheets(3).Cells(11, j) = Worksheets(7).Range("F40") Then
Worksheets(3).Cells(11, j).Interior.ColorIndex = 15
End If

If Worksheets(3).Cells(11, j) = Worksheets(7).Range("F41") Then
Worksheets(3).Cells(11, j).Interior.ColorIndex = 15
End If

If Worksheets(3).Cells(11, j) = Worksheets(7).Range("G40") Then
Worksheets(3).Cells(11, j).Interior.ColorIndex = 15
End If

If Worksheets(3).Cells(11, j) = Worksheets(7).Range("G41") Then
Worksheets(3).Cells(11, j).Interior.ColorIndex = 15
End If

If Worksheets(3).Cells(11, j) = Worksheets(7).Range("H40") Then
Worksheets(3).Cells(11, j).Interior.ColorIndex = 15
End If

If Worksheets(3).Cells(11, j) = Worksheets(7).Range("H41") Then
Worksheets(3).Cells(11, j).Interior.ColorIndex = 15
End If

If Worksheets(3).Cells(11, j) = Worksheets(7).Range("I40") Then
Worksheets(3).Cells(11, j).Interior.ColorIndex = 15
End If

If Worksheets(3).Cells(11, j) = Worksheets(7).Range("I41") Then
Worksheets(3).Cells(11, j).Interior.ColorIndex = 15
End If

If Worksheets(3).Cells(11, j) = Worksheets(7).Range("J40") Then
Worksheets(3).Cells(11, j).Interior.ColorIndex = 15
End If

If Worksheets(3).Cells(11, j) = Worksheets(7).Range("J41") Then
Worksheets(3).Cells(11, j).Interior.ColorIndex = 15
End If
Next

Worksheets(3).Range("D11:AH11").Copy Worksheets(4).Range("D11:AH11")
Worksheets(3).Range("D11:AH11").Copy Worksheets(5).Range("D11:AH11")

Worksheets(3).Columns("AD:AH").EntireColumn.Hidden = False
Worksheets(4).Columns("AD:AH").EntireColumn.Hidden = False
Worksheets(5).Columns("AD:AH").EntireColumn.Hidden = False
   
Application.ScreenUpdating = True

End Sub
[/vba]
 
Ответить
Сообщение[vba]
Код
Sub КАЛЕНДАРЬ()
Application.ScreenUpdating = False

If Worksheets(7).Range("J34").Value <> 29 Then
Worksheets(3).Range("AF11").Value = ""
Else
Worksheets(3).Range("AF11").Value = 29
Worksheets(3).Range("AG11").Value = ""
Worksheets(3).Range("AH11").Value = ""
End If

If Worksheets(7).Range("J34").Value <> 30 Then
Worksheets(3).Range("AG11").Value = ""
Else
Worksheets(3).Range("AF11").Value = 29
Worksheets(3).Range("AG11").Value = 30
Worksheets(3).Range("AH11").Value = ""
End If

If Worksheets(7).Range("J34").Value <> 31 Then
Worksheets(3).Range("AH11").Value = ""
Else
Worksheets(3).Range("AF11").Value = 29
Worksheets(3).Range("AG11").Value = 30
Worksheets(3).Range("AH11").Value = 31
End If

Worksheets(3).Range("D11:AH11").Interior.ColorIndex = xlNone
Worksheets(4).Range("D11:AH11").Interior.ColorIndex = xlNone
Worksheets(5).Range("D11:AH11").Interior.ColorIndex = xlNone

n = 0
While Worksheets(3).Cells(n + 11, 4).Value <> ""
n = n + 1
Wend
For j = 4 To n + 30

If Worksheets(3).Cells(11, j) = Worksheets(7).Range("E40") Then
Worksheets(3).Cells(11, j).Interior.ColorIndex = 15
End If

If Worksheets(3).Cells(11, j) = Worksheets(7).Range("E41") Then
Worksheets(3).Cells(11, j).Interior.ColorIndex = 15
End If

If Worksheets(3).Cells(11, j) = Worksheets(7).Range("F40") Then
Worksheets(3).Cells(11, j).Interior.ColorIndex = 15
End If

If Worksheets(3).Cells(11, j) = Worksheets(7).Range("F41") Then
Worksheets(3).Cells(11, j).Interior.ColorIndex = 15
End If

If Worksheets(3).Cells(11, j) = Worksheets(7).Range("G40") Then
Worksheets(3).Cells(11, j).Interior.ColorIndex = 15
End If

If Worksheets(3).Cells(11, j) = Worksheets(7).Range("G41") Then
Worksheets(3).Cells(11, j).Interior.ColorIndex = 15
End If

If Worksheets(3).Cells(11, j) = Worksheets(7).Range("H40") Then
Worksheets(3).Cells(11, j).Interior.ColorIndex = 15
End If

If Worksheets(3).Cells(11, j) = Worksheets(7).Range("H41") Then
Worksheets(3).Cells(11, j).Interior.ColorIndex = 15
End If

If Worksheets(3).Cells(11, j) = Worksheets(7).Range("I40") Then
Worksheets(3).Cells(11, j).Interior.ColorIndex = 15
End If

If Worksheets(3).Cells(11, j) = Worksheets(7).Range("I41") Then
Worksheets(3).Cells(11, j).Interior.ColorIndex = 15
End If

If Worksheets(3).Cells(11, j) = Worksheets(7).Range("J40") Then
Worksheets(3).Cells(11, j).Interior.ColorIndex = 15
End If

If Worksheets(3).Cells(11, j) = Worksheets(7).Range("J41") Then
Worksheets(3).Cells(11, j).Interior.ColorIndex = 15
End If
Next

Worksheets(3).Range("D11:AH11").Copy Worksheets(4).Range("D11:AH11")
Worksheets(3).Range("D11:AH11").Copy Worksheets(5).Range("D11:AH11")

Worksheets(3).Columns("AD:AH").EntireColumn.Hidden = False
Worksheets(4).Columns("AD:AH").EntireColumn.Hidden = False
Worksheets(5).Columns("AD:AH").EntireColumn.Hidden = False
   
Application.ScreenUpdating = True

End Sub
[/vba]
Автор - tasdel
Дата добавления - 31.03.2020 в 17:26
tasdel Дата: Вторник, 31.03.2020, 17:29 | Сообщение № 8
Группа: Проверенные
Ранг: Форумчанин
Сообщений: 144
Репутация: 0 ±
Замечаний: 20% ±

Excel 2007
Pelena, В этом коде уже присутствуют дополнения, которые выполняют другие задачи.
 
Ответить
СообщениеPelena, В этом коде уже присутствуют дополнения, которые выполняют другие задачи.
Автор - tasdel
Дата добавления - 31.03.2020 в 17:29
tasdel Дата: Вторник, 31.03.2020, 17:55 | Сообщение № 9
Группа: Проверенные
Ранг: Форумчанин
Сообщений: 144
Репутация: 0 ±
Замечаний: 20% ±

Excel 2007
Pelena, Я знаю, Вы бы все это дело упаковали в 5-6 строк, но для меня главное результат, получилось как получилось, зато работает. :)
 
Ответить
СообщениеPelena, Я знаю, Вы бы все это дело упаковали в 5-6 строк, но для меня главное результат, получилось как получилось, зато работает. :)
Автор - tasdel
Дата добавления - 31.03.2020 в 17:55
gling Дата: Вторник, 31.03.2020, 19:36 | Сообщение № 10
Группа: Друзья
Ранг: Участник клуба
Сообщений: 2563
Репутация: 706 ±
Замечаний: 0% ±

2010
Цитата tasdel, 31.03.2020 в 17:25, в сообщении № 6 ()
у меня выделяло Пятницы и Субботы

Извиняюсь, формулу написал не полностью, не указал начало недели. Нужно было в УФ записать такую формулу
Код
=ДЕНЬНЕД(D11;2)>5

ЯД-41001506838083
 
Ответить
Сообщение
Цитата tasdel, 31.03.2020 в 17:25, в сообщении № 6 ()
у меня выделяло Пятницы и Субботы

Извиняюсь, формулу написал не полностью, не указал начало недели. Нужно было в УФ записать такую формулу
Код
=ДЕНЬНЕД(D11;2)>5
Автор - gling
Дата добавления - 31.03.2020 в 19:36
Мир MS Excel » Вопросы и решения » Вопросы по VBA » Перенос чисел из календаря на другой лист (Макросы/Sub)
  • Страница 1 из 1
  • 1
Поиск:

Яндекс.Метрика Яндекс цитирования
© 2010-2024 · Дизайн: MichaelCH · Хостинг от uCoz · При использовании материалов сайта, ссылка на www.excelworld.ru обязательна!