[已解决]关于把鼠标选定单元格的值复制到另一工作薄的代码。

过江龙

请各位老师帮帮忙，写一段把附件中《资料库》工作薄鼠标选定的单元格的值复制在《固定账号》工作薄中的代码，做成加载宏，谢谢！ 桌面.rar (5.07 KB, 下载次数: 8)

2014-4-9 16:43 上传

点击文件名下载附件

最佳答案

月排行榜 / 总排行榜

dsmch

2014-4-11 13:37

这些都不成问题，关键你的思路要理清，选中就复制过去，那边就成了一个垃圾场了。

跳转到最佳答案楼层

过江龙

这个的要求不能实现吗？

dsmch

可以实现，不过太浪费资源，选中一次，打开工作簿一次（无论是前台或后台打开），保存关闭。

过江龙

dsmch 发表于 2014-4-10 16:42
可以实现，不过太浪费资源，选中一次，打开工作簿一次（无论是前台或后台打开），保存关闭。

请问，代码该怎么写呢？

dsmch

1. Private Sub Worksheet_SelectionChange(ByVal Target As Range)
   
2. If Not Application.Intersect(ActiveSheet.UsedRange, Target) Is Nothing Then
   
3.     Application.ScreenUpdating = False
   
4.     Application.DisplayAlerts = False
   
5.     Dim wb As Workbook, rng As Range, y&, x&
   
6.     y = Target.Column: z = Target.Value
   
7.     Set wb = GetObject(ThisWorkbook.Path & "\固定账号.xls")
   
8.     Application.Windows(wb.Name).Visible = True
   
9.     With wb.Sheets(1)
   
10.         Set rng = .Columns(y).Find(z, lookat:=xlWhole)
    
11.         If rng Is Nothing Then
    
12.             x = .Cells(65536, y).End(xlUp).Row + 1
    
13.             .Cells(x, y) = z
    
14.         End If
    
15.     End With
    
16.     wb.Close 1
    
17.     Application.DisplayAlerts = True
    
18.     Application.ScreenUpdating = True
    
19. End If
    
20. End Sub
    

复制代码

dsmch

………………

过江龙

dsmch 发表于 2014-4-11 12:41

谢谢关注！你的代码只能实现一个单元格的复制，我的意思是鼠标选中多少区域就复制多少区域，能实现吗？

dsmch

这些都不成问题，关键你的思路要理清，选中就复制过去，那边就成了一个垃圾场了。

过江龙

dsmch 发表于 2014-4-11 13:37
这些都不成问题，关键你的思路要理清，选中就复制过去，那边就成了一个垃圾场了。

换一种思路，先打开一个工作簿，如《固定账号》等（注意：工作簿名称不固定），然后把需要的账号从资料库工作簿中复制过来。
Sub 复制选定连续单元格()
Dim Wb As Workbook
Dim h
Dim rng As Range
    On Error Resume Next
    For Each Wb In Workbooks
       If Wb.Name = "资料库.xls" Then
        h = h + 1
       End If
    Next
    If h < 1 Then
        Workbooks.Open Filename:=ThisWorkbook.Path & "\资料库.xls"    End If
       Set rng = Application.InputBox("请选择需要复制的区域", "提示选择", , , , , , 8)
    rng.Copy Cells(Range("A65536").End(xlUp).Row + 1, 1)
End Sub
如何把红色部分指定为先前打开的工作簿？

过江龙

换种思路后，解决。现在菜单栏做一个按钮。
Sub 复制选定连续单元格()
Dim Wb As Workbook
Dim h, arr1, Name
Dim rng As Range
    On Error Resume Next
    Name = ActiveWorkbook.Name
   
    For Each Wb In Workbooks
       If Wb.Name = "资料库.xls"  Then
        h = h + 1
       End If
    Next
    Workbooks("资料库.xls").Activate
    If h < 1 Then
        Workbooks.Open Filename:=ThisWorkbook.Path & "\资料库.xls"    End If
   
    Set rng = Application.InputBox("请选择需要复制的区域", "提示选择", , , , , , 8)
    arr1 = rng.Value
    Workbooks(Name).Activate
    Cells(Range("A65536").End(xlUp).Row + 1, 1).Resize(UBound(arr1), UBound(arr1, 2)) = arr1
End Sub