[已解决]求助高手们来看看。

exlover · 发表于 2013-10-21 20:06

本帖最后由 exlover 于 2013-10-21 23:23 编辑

求助可否办到。

最佳答案

月排行榜 / 总排行榜

hwc2ycy

2013-10-21 20:48

Sub test1()
Dim rg As Range, rg2 As Range
Dim lLastRow As Long
Dim arr
On Error Resume Next
Set rg = Application.InputBox("请选择要复制的多区域", Type:=8)
If Err.Number <> 0 Then Exit Sub
With Worksheets("sheet3")
lLastRow = .Cells(Rows.Count, 1).End(xlUp).Row + 2
For Each rg2 In rg.Areas
arr = rg2.Value
With .Cells(lLastRow, 1)
If IsArray(arr) Then
.Resize(UBound(arr), UBound(arr, 2)).Value = arr
Else
.Value = arr
End If
End With
lLastRow = .Cells(Rows.Count, 1).End(xlUp).Row + 1
Next
End With
MsgBox "复制完成"
End Sub
Sub test2()
Dim rg As Range, rg2 As Range
Dim lLastRow As Long
Dim arr
On Error Resume Next
Set rg = Application.InputBox("请选择要复制的多区域", Type:=8)
If Err.Number <> 0 Then Exit Sub
With Worksheets("sheet3")
For Each rg2 In rg.Areas
arr = rg2.Value
lLastRow = .Cells(Rows.Count, 1).End(xlUp).Row + 1
With .Cells(lLastRow, 1)
If IsArray(arr) Then
.Resize(UBound(arr), UBound(arr, 2)).Value = arr
Else
.Value = arr
End If
End With
lLastRow = .Cells(Rows.Count, 1).End(xlUp).Row + 1
Next
End With
MsgBox "复制完成"
End Sub

复制代码

跳转到最佳答案楼层

hwc2ycy · 发表于 2013-10-21 20:42

Sub test1()
Dim rg As Range, rg2 As Range
Dim lLastRow As Long
Dim arr
On Error Resume Next
Set rg = Application.InputBox("请选择要复制的多区域", Type:=8)
If Err.Number <> 0 Then Exit Sub
With Worksheets("sheet3")
lLastRow = .Cells(Rows.Count, 1).End(xlUp).Row + 2
For Each rg2 In rg.Areas
arr = rg2.Value
If IsArray(arr) Then
.Cells(lLastRow, 1).Resize(UBound(arr), UBound(arr, 2)).Value = arr
Else
.Cells(lLastRow, 1).Value = arr
End If
lLastRow = .Cells(Rows.Count, 1).End(xlUp).Row + 1
Next
End With
MsgBox "复制完成"
End Sub

复制代码

hwc2ycy · 发表于 2013-10-21 20:48

这个最佳答案由 hwc2ycy 给出，感谢 hwc2ycy 的回答。

单击隐藏图章

Sub test1()
Dim rg As Range, rg2 As Range
Dim lLastRow As Long
Dim arr
On Error Resume Next
Set rg = Application.InputBox("请选择要复制的多区域", Type:=8)
If Err.Number <> 0 Then Exit Sub
With Worksheets("sheet3")
lLastRow = .Cells(Rows.Count, 1).End(xlUp).Row + 2
For Each rg2 In rg.Areas
arr = rg2.Value
With .Cells(lLastRow, 1)
If IsArray(arr) Then
.Resize(UBound(arr), UBound(arr, 2)).Value = arr
Else
.Value = arr
End If
End With
lLastRow = .Cells(Rows.Count, 1).End(xlUp).Row + 1
Next
End With
MsgBox "复制完成"
End Sub
Sub test2()
Dim rg As Range, rg2 As Range
Dim lLastRow As Long
Dim arr
On Error Resume Next
Set rg = Application.InputBox("请选择要复制的多区域", Type:=8)
If Err.Number <> 0 Then Exit Sub
With Worksheets("sheet3")
For Each rg2 In rg.Areas
arr = rg2.Value
lLastRow = .Cells(Rows.Count, 1).End(xlUp).Row + 1
With .Cells(lLastRow, 1)
If IsArray(arr) Then
.Resize(UBound(arr), UBound(arr, 2)).Value = arr
Else
.Value = arr
End If
End With
lLastRow = .Cells(Rows.Count, 1).End(xlUp).Row + 1
Next
End With
MsgBox "复制完成"
End Sub

复制代码

hwc2ycy · 发表于 2013-10-21 20:49

test1是epTWO，弹出对话框后，直接选中区域操作即可
test2是epone，弹出对话框后，直接选中区域操作即可

exlover · 发表于 2013-10-21 21:03

hwc2ycy 发表于 2013-10-21 20:49
test1是epTWO，弹出对话框后，直接选中区域操作即可
test2是epone，弹出对话框后，直接选中区域操作即可

非常感谢版主的解答，操作方式可以这样么.

我先选取好单元格，然后做2个按钮，用单击按钮来完成要求。
这样操控性比较好。版主老师可否再修改下代码。

exlover · 发表于 2013-10-21 21:08

本帖最后由 exlover 于 2013-10-21 21:20 编辑

hwc2ycy 发表于 2013-10-21 20:48

你好，版主老师。
1.本求助中，可否把代码用按钮来控制。即先选取好要复制的单元格，然后单击按钮，实现复制粘贴效果。这样实际使用起来比较方便。
2.实际代码运行后不能完成以上2个附件效果。总计是2个选取方式：
第1个附件选取单元格是一次选取三个单元格。它的粘贴结果到sheet2是紧挨着一行一行的。
第2个附件选取单元格是一次选取同行的三段三个单元格，它的粘贴结果复制到sheet3。且每选取一次，它的结果需要隔一行放置。与第一个附件紧挨一行一行放置有些区别。

hwc2ycy · 发表于 2013-10-21 21:20

eponetwo.rar (24.07 KB, 下载次数: 8)

exlover · 发表于 2013-10-21 21:38

本帖最后由 exlover 于 2013-10-21 23:17 编辑

hwc2ycy 发表于 2013-10-21 21:20

谢谢老师，就是第一次复制的时候，sheet3里的结果是从第一行开始的比较好。

比如我把sheet3里的数据全部清空后，它总是从第三行开始的。

hwc2ycy · 发表于 2013-10-21 22:44

exlover 发表于 2013-10-21 21:38
就是有一点点问题及咨询下。
1：2个文件里选取后复制第一次的时候，结果都不是从第一行开始的放置的。 ...

你每次都要从第一行开始写？
那原有的数据清空后你可不要说要恢复数据。

exlover · 发表于 2013-10-21 23:21

hwc2ycy 发表于 2013-10-21 22:44
你每次都要从第一行开始写？
那原有的数据清空后你可不要说要恢复数据。

谢谢。也就是我把sheet3里的数据全部清空后。
做这样的复制，是从sheet3的第三行开始填入的。
不过，就是这里一点点。其它都很好。也基本达到。就是多了一步把sheet3里的前2行空格删除下。
已设最佳，再次感谢！！！

		自动登录	找回密码
密码			注册