高难度的“异表复制问题”

qhllqhll

谢谢老师问题解决了
还的请教老师您，
1、我实际上要粘贴的位置是“工作薄1”sheet2里的 A4单元格
2、要输入的好号必须大于或等于4
请问怎么再修改代码，
谢谢
你看老是给您添麻烦 不好意思

[ 本帖最后由 qhllqhll 于 2011-3-16 11:20 编辑 ]

dsmch

On Error Resume Next
Dim ws As Worksheet, arr
Application.ScreenUpdating = False
Set ws = ThisWorkbook.Sheets(2)
ws.Cells.ClearContents
x = Val(InputBox("输入行号，行号大于等于4："))
If x < 4 Then Exit Sub
Workbooks.Open Filename:=ThisWorkbook.Path & "\工作薄2"
Sheets(1).Activate
arr = Range(Cells(x, 1), Cells(x + 99, "o"))
ws.Range("a4").Resize(UBound(arr), UBound(arr, 2)) = arr
Workbooks("工作薄2").Close
Application.ScreenUpdating = True

qhllqhll

好 首先谢谢您

qhllqhll

老师您好：
请问如果“工作薄2”名字不定的情况下，能否提取内容啊？例如：“工作薄2”的名字改成“xyz”或“花名册”等等，的代码应该怎么修改啊。
我的意思：只要把和“工作薄2”格式相同的其他名的工作薄和“工作薄1"放在同一个文件夹里，就能采集到“工作薄1”里。
谢谢

[ 本帖最后由 qhllqhll 于 2011-3-16 17:20 编辑 ]

dsmch

方法很多，可以用
Application.FileSearch
Application.GetOpenFilename
具体看联机帮助。

qhllqhll

老师 我不太懂 麻烦您在下面的代码里 修改一下吧 谢谢
On Error Resume Next
Dim ws As Worksheet, arr
Application.ScreenUpdating = False
Set ws = ThisWorkbook.Sheets(2)
ws.Cells.ClearContents
x = Val(InputBox("输入行号，行号大于等于4："))
If x < 4 Then Exit Sub
Workbooks.Open Filename:=ThisWorkbook.Path & "\工作薄2"
Sheets(1).Activate
arr = Range(Cells(x, 1), Cells(x + 99, "o"))
ws.Range("a4").Resize(UBound(arr), UBound(arr, 2)) = arr
Workbooks("工作薄2").Close
Application.ScreenUpdating = True

qhllqhll

这个问题我曾经发过好几个贴子了
都没解决了
请您有时间的话帮我看看
谢谢

dsmch

On Error Resume Next
Dim ws As Worksheet, arr, wj As String
Application.ScreenUpdating = False
Set ws = ThisWorkbook.Sheets(2)
ws.Cells.ClearContents
wj = Dir(ThisWorkbook.Path & "\")
x = Val(InputBox("输入行号，行号大于等于4："))
If x < 4 Then Exit Sub
Workbooks.Open Filename:=ThisWorkbook.Path & "\" & wj
Sheets(1).Activate
arr = Range(Cells(x, 1), Cells(x + 99, "o"))
ws.Range("a4").Resize(UBound(arr), UBound(arr, 2)) = arr
Workbooks(wj).Close
Application.ScreenUpdating = True

qhllqhll

老师您好再问您一个问题：如果吧复制来的内容以 “数值”格式粘贴到 “a4”,，应该怎样改写 “  ws.Range("a4").Resize(UBound(arr), UBound(arr, 2)) = arr   ” 代码啊？
谢谢

dsmch

和代码无关，增加一句设置a列格式的代码。