设为首页收藏本站
开启辅助访问

Excel精英培训网

 找回密码
 注册
Excel精英培训网»论坛 › Excel 求助区 › Excel VBA开发 › 自动填充日期
数据透视表40+个常用小技巧，让你一次学会！
返回列表 发新帖
查看: 2567|回复: 7

[已解决]自动填充日期

[复制链接]
发表于 2016-7-14 16:21 | 显示全部楼层 |阅读模式
工作中常用的Excel函数公式，全印在一张超大鼠标垫上
本帖最后由 cunfu2010 于 2016-7-16 10:37 编辑

当A1单元格输入年份，回车，则自动填充日期。工作薄中区分了三种样式，分别对应sheet1、sheet2、sheet3。求帮忙分别写一下代码，谢谢！
最佳答案
月排行榜 / 总排行榜
老司机带带我
2016-7-15 21:47
cunfu2010 发表于 2016-7-15 20:27
传附件没成功，文字说明一下吧
就是当工作表中某天（单元格）为红色时，依据这个单元格，每隔12天，就有 ...

SHEET1：
  1. Private Sub Worksheet_Change(ByVal Target As Range)
  2.     Dim i%, j%, t As Date, x%, b As Boolean
  3.     If Target.Address <> "$A$1" Then Exit Sub
  4.     If Target = "" Then Exit Sub
  5.     t = CDate(Target.Value - 1 & "-12-31")
  6.     j = 1
  7.     Do
  8.         j = j + 1
  9.         For i = 1 To 10
  10.             t = t + 1
  11.             If Year(t) <> Target.Value Then Exit Sub
  12.             Cells(j, i) = t
  13.             If Cells(j, i).Interior.Color = 255 Then b = True
  14.             If b = True Then x = x + 1
  15.             If x <> 0 And x Mod 14 = 0 Then Cells(j, i).Interior.Color = 255
  16.         Next
  17.     Loop While Year(t) = Target.Value
  18. End Sub
复制代码
SHEET3：
  1. Private Sub Worksheet_Change(ByVal Target As Range)
  2.     Dim i%, j%, t As Date, x%, b As Boolean
  3.     If Target.Address <> "$A$1" Then Exit Sub
  4.     If Target = "" Then Exit Sub
  5.     t = CDate(Target.Value - 1 & "-12-31")
  6.     j = 2
  7.     Do
  8.         For i = 1 To 10
  9.             t = t + 1
  10.             If Year(t) <> Target.Value Then Exit Sub
  11.             Cells(j, i) = t
  12.             Cells(j + 1, i) = Format(t, "aaaa")
  13.             If Cells(j, i).Interior.Color = 255 Then b = True
  14.             If b = True Then x = x + 1
  15.             If x <> 0 And x Mod 14 = 0 Then Cells(j, i).Interior.Color = 255
  16.         Next
  17.         j = j + 3
  18.     Loop While Year(t) = Target.Value
  19. End Sub
复制代码
SHEET2不知道怎么弄！下次提问的时候最好把需求一次性提完！

自动填充日期（三种样式）.rar

10.13 KB, 下载次数: 32
excel精英培训的微信平台，每天都会发送excel学习教程和资料。扫一扫明天就可以收到新教程
回复

使用道具 举报

工作中最常用的函数公式，全印在一张超大的鼠标垫上
发表于 2016-7-14 17:09 | 显示全部楼层
工作中常用的Excel函数公式，全印在一张超大鼠标垫上
没理解意思啊！
回复

使用道具 举报

 楼主| 发表于 2016-7-14 17:18 | 显示全部楼层
工作中最常用的Excel函数公式，全印在一张鼠标垫上
老司机带带我 发表于 2016-7-14 17:09
没理解意思啊！

想通过VBA代码实现自动填充全年日期
回复

使用道具 举报

发表于 2016-7-14 20:11 | 显示全部楼层
本帖最后由 老司机带带我 于 2016-7-14 20:15 编辑

66kb的附件说文件太大上传不上来，每个工作表的工作表事件如下：
sheet1:
  1. Private Sub Worksheet_Change(ByVal Target As Range)
  2.     Dim i%, j%, t As Date
  3.     If Target.Address <> "$A$1" Then Exit Sub
  4.     If Target = "" Then Exit Sub
  5.     t = CDate(Target.Value - 1 & "-12-31")
  6.     j = 1
  7.     Do
  8.         j = j + 1
  9.         For i = 1 To 10
  10.             t = t + 1
  11.             If Year(t) <> Target.Value Then Exit Sub
  12.             Cells(j, i) = t
  13.         Next
  14.     Loop While Year(t) = Target.Value
  15. End Sub
复制代码
sheet2:
  1. Private Sub Worksheet_Change(ByVal Target As Range)
  2.     Dim i%, j%, t As Date
  3.     If Target.Address <> "$A$1" Then Exit Sub
  4.     If Target = "" Then Exit Sub
  5.     x = 2
  6.     For i = 1 To 12
  7.         t = CDate(Target.Value & "-" & i & "-1")
  8.         For j = 1 To Day(Application.WorksheetFunction.EoMonth(t, 0))
  9.             Cells(x, j) = t + j - 1
  10.             Cells(x + 1, j) = Format(t + j - 1, "aaaa")
  11.         Next
  12.         x = x + 5
  13.     Next
  14. End Sub
复制代码
sheet3:
  1. Private Sub Worksheet_Change(ByVal Target As Range)
  2.     Dim i%, j%, t As Date
  3.     If Target.Address <> "$A$1" Then Exit Sub
  4.     If Target = "" Then Exit Sub
  5.     t = CDate(Target.Value - 1 & "-12-31")
  6.     j = 2
  7.     Do
  8.         For i = 1 To 10
  9.             t = t + 1
  10.             If Year(t) <> Target.Value Then Exit Sub
  11.             Cells(j, i) = t
  12.             Cells(j + 1, i) = Format(t, "aaaa")
  13.         Next
  14.         j = j + 3
  15.     Loop While Year(t) = Target.Value
  16. End Sub
复制代码
回复

使用道具 举报

 楼主| 发表于 2016-7-15 15:11 | 显示全部楼层
本帖最后由 cunfu2010 于 2016-7-15 15:40 编辑
老司机带带我 发表于 2016-7-14 20:11
66kb的附件说文件太大上传不上来，每个工作表的工作表事件如下：
sheet1:sheet2:sheet3:

你好，如果某单元格底色为红色，那么每隔13天单元格也为红色。即：A1为红色，则D4为红色，后面依次类推。
回复

使用道具 举报

 楼主| 发表于 2016-7-15 20:27 | 显示全部楼层
老司机带带我 发表于 2016-7-14 20:11
66kb的附件说文件太大上传不上来，每个工作表的工作表事件如下：
sheet1:sheet2:sheet3:

传附件没成功，文字说明一下吧
就是当工作表中某天（单元格）为红色时，依据这个单元格，每隔12天，就有一天为红色
当A2底色为红色时，D3为红色，G4为红色，J5为红色，C7为红色，F8为红色，依次类推。
不知道说清楚了没。
回复

使用道具 举报

发表于 2016-7-15 21:47 | 显示全部楼层    本楼为最佳答案   
cunfu2010 发表于 2016-7-15 20:27
传附件没成功，文字说明一下吧
就是当工作表中某天（单元格）为红色时，依据这个单元格，每隔12天，就有 ...

SHEET1：
  1. Private Sub Worksheet_Change(ByVal Target As Range)
  2.     Dim i%, j%, t As Date, x%, b As Boolean
  3.     If Target.Address <> "$A$1" Then Exit Sub
  4.     If Target = "" Then Exit Sub
  5.     t = CDate(Target.Value - 1 & "-12-31")
  6.     j = 1
  7.     Do
  8.         j = j + 1
  9.         For i = 1 To 10
  10.             t = t + 1
  11.             If Year(t) <> Target.Value Then Exit Sub
  12.             Cells(j, i) = t
  13.             If Cells(j, i).Interior.Color = 255 Then b = True
  14.             If b = True Then x = x + 1
  15.             If x <> 0 And x Mod 14 = 0 Then Cells(j, i).Interior.Color = 255
  16.         Next
  17.     Loop While Year(t) = Target.Value
  18. End Sub
复制代码
SHEET3：
  1. Private Sub Worksheet_Change(ByVal Target As Range)
  2.     Dim i%, j%, t As Date, x%, b As Boolean
  3.     If Target.Address <> "$A$1" Then Exit Sub
  4.     If Target = "" Then Exit Sub
  5.     t = CDate(Target.Value - 1 & "-12-31")
  6.     j = 2
  7.     Do
  8.         For i = 1 To 10
  9.             t = t + 1
  10.             If Year(t) <> Target.Value Then Exit Sub
  11.             Cells(j, i) = t
  12.             Cells(j + 1, i) = Format(t, "aaaa")
  13.             If Cells(j, i).Interior.Color = 255 Then b = True
  14.             If b = True Then x = x + 1
  15.             If x <> 0 And x Mod 14 = 0 Then Cells(j, i).Interior.Color = 255
  16.         Next
  17.         j = j + 3
  18.     Loop While Year(t) = Target.Value
  19. End Sub
复制代码
SHEET2不知道怎么弄！下次提问的时候最好把需求一次性提完！
回复

使用道具 举报

 楼主| 发表于 2016-7-16 10:37 | 显示全部楼层
老司机带带我 发表于 2016-7-15 21:47
SHEET1：SHEET3：SHEET2不知道怎么弄！下次提问的时候最好把需求一次性提完！

太感谢了！
回复

使用道具 举报

返回列表 发新帖
高级模式
B Color Image Link Quote Code Smilies
您需要登录后才可以回帖 登录 | 注册

本版积分规则

小黑屋|手机版|Archiver|Excel精英培训 ( 豫ICP备11015029号 )

GMT+8, 2024-4-27 01:13 , Processed in 0.772520 second(s), 9 queries , Gzip On, Yac On.

Powered by Discuz! X3.4

Copyright © 2001-2020, Tencent Cloud.

快速回复 返回顶部 返回列表