Перенос чисел из календаря на другой лист

Старая форма входа

Страница 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)

Ответить

gling

Дата: Воскресенье, 29.03.2020, 21:06 | Сообщение № 2

Группа: Друзья

Ранг: Участник клуба

Сообщений: 2519

Репутация: 674 ±

Замечаний: 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, 21:43 | Сообщение № 3

Группа: Проверенные

Ранг: Форумчанин

Сообщений: 144

Репутация: 0 ±

Замечаний: 20% ±

Excel 2007

gling, Спасибо что откликнулись. Я все-таки написал код. Все работает, как я планировал. Утром наверное не с той ноги встал, поэтому туго соображалось.
Спасибо всем, тема закрыта!!!

Ответить

Pelena

Дата: Воскресенье, 29.03.2020, 21:46 | Сообщение № 4

Группа: Админы

Ранг: Местный житель

Сообщений: 19174

Репутация: 4413 ±

Замечаний: ±

Excel 365 & Mac Excel

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

"Черт возьми, Холмс! Но как??!!"
Ю-money 41001765434816

Ответить

Shylo

Дата: Вторник, 31.03.2020, 13:02 | Сообщение № 5

Группа: Проверенные

Ранг: Форумчанин

Сообщений: 155

Репутация: 7 ±

Замечаний: 0% ±

Excel-2003; 2010

По варианту файла Владимира, у меня выделяло Пятницы и Субботы (в 2003 и 2007), сделал вариант УФ на Субботы и Воскресенья для 2003 и выше.

К сообщению приложен файл: ___.xls (44.0 Kb)

Ответить

tasdel

Дата: Вторник, 31.03.2020, 17:25 | Сообщение № 6

Группа: Проверенные

Ранг: Форумчанин

Сообщений: 144

Репутация: 0 ±

Замечаний: 20% ±

Excel 2007

Pelena, Здравствуйте!!! Получилось так, что Вы написали мне сообщение после того, как я удалился из форума.
Я свой код уже зарядил в свою рабочую книгу, где уже очень много было нахимичено. Естественно я его уже завязал с основной рабочей кодовой процедурой.
Весь файл выложить не получиться, так как он превышает местный лимит по объему.Попытался выдернуть лист с макросом из книги, не получилось, т.к. ексель начал на меня ругаться. Я уже не стал влезать в дебри, выяснять причину ошибки. Могу выложить код - как есть, только уже с другими координатами.

Ответить

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]

Код