[已解决]点击单元格，生成新工作表

chenhu1981

大家好！ 点击生成工作表.zip (15.16 KB, 下载次数: 7)

2016-12-19 15:17 上传

点击文件名下载附件 我想通过点击A列的方式，提取该单元格往上数的三十条数据放到另一张工作表中，工作表名用当前单元格的内容
例如我点击A32，那么将A32(包括A32)以上的30条数据放到新的工作表，并以A32的内容作为工作表名称
如果点击的单元格对上不足30条数据，那么直提取该单元格对上的所有数据。
谢谢！

最佳答案

月排行榜 / 总排行榜

望帝春心

2016-12-24 11:20

chenhu1981 发表于 2016-12-19 21:05
谢谢楼上大哥的帮忙，能否做成左键双击激活事件呢，谢谢！

1. Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
   
2. Dim r&, rng As Range
   
3.     Application.ScreenUpdating = False
   
4.     r = Application.WorksheetFunction.Max(Target.Row + 1 - 30, 1)
   
5.     Set rng = Cells(r, 1).Resize(Target.Row - r + 1, 7)
   
6.     On Error Resume Next
   
7.     Set sht = Worksheets(Target.Value): sht.Cells.Clear
   
8.     If Err.Number <> 0 Then
   
9.     Worksheets.Add.Name = Target.Value
   
10.     ActiveSheet.Move after:=Worksheets(Sheets.Count)
    
11.     Err.Clear
    
12.     End If
    
13.     rng.Copy Worksheets(Target.Value).[a1]
    
14.     Application.ScreenUpdating = True
    
15. End Sub

复制代码

跳转到最佳答案楼层

望帝春心

1. Private Sub Worksheet_BeforeRightClick(ByVal Target As Range, Cancel As Boolean)
   
2.     Dim r&, rng As Range
   
3.     Application.ScreenUpdating = False
   
4.     r = Application.WorksheetFunction.Max(Target.Row + 1 - 30, 1)
   
5.     Set rng = Cells(r, 1).Resize(Target.Row - r + 1, 7)
   
6.     On Error Resume Next
   
7.     Set sht = Worksheets(Target.Value): sht.Cells.Clear
   
8.     If Err.Number <> 0 Then
   
9.     Worksheets.Add.Name = Target.Value
   
10.     ActiveSheet.Move after:=Worksheets(Sheets.Count)
    
11.     Err.Clear
    
12.     End If
    
13.     rng.Copy Worksheets(Target.Value).[a1]
    
14.     Application.ScreenUpdating = True
    
15. End Sub

复制代码

鼠标右键单击事件

望帝春心

1. 参考附件

复制代码

chenhu1981

谢谢楼上大哥的帮忙，能否做成左键双击激活事件呢，谢谢！

望帝春心

chenhu1981 发表于 2016-12-19 21:05
谢谢楼上大哥的帮忙，能否做成左键双击激活事件呢，谢谢！

1. Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
   
2. Dim r&, rng As Range
   
3.     Application.ScreenUpdating = False
   
4.     r = Application.WorksheetFunction.Max(Target.Row + 1 - 30, 1)
   
5.     Set rng = Cells(r, 1).Resize(Target.Row - r + 1, 7)
   
6.     On Error Resume Next
   
7.     Set sht = Worksheets(Target.Value): sht.Cells.Clear
   
8.     If Err.Number <> 0 Then
   
9.     Worksheets.Add.Name = Target.Value
   
10.     ActiveSheet.Move after:=Worksheets(Sheets.Count)
    
11.     Err.Clear
    
12.     End If
    
13.     rng.Copy Worksheets(Target.Value).[a1]
    
14.     Application.ScreenUpdating = True
    
15. End Sub

复制代码

望帝春心

chenhu1981 发表于 2016-12-19 21:05
谢谢楼上大哥的帮忙，能否做成左键双击激活事件呢，谢谢！

回复要点楼层回复，不然没提醒别人看不到的