Question

求VBA高手，把工作簿的特定区域，复制粘贴到新工作簿中。

已经实现了的如下：
将读取一个文件夹内所有工作簿中工作表Sheet1上单元格A1中的值到一个新工作簿中。

Sub Macro1()
Dim FolderName As String, wbName As String, r As Long, cValue As Variant
Dim wbList() As String, wbCount As Integer, i As Integer
FolderName = "C:\批处理"
'创建文件夹中工作簿列表
wbCount = 0
wbName = Dir(FolderName & "\" & "*.xls")
While wbName <> ""
wbCount = wbCount + 1
ReDim Preserve wbList(1 To wbCount)
wbList(wbCount) = wbName
wbName = Dir
Wend
If wbCount = 0 Then Exit Sub
'从每个工作簿中获取数据
r = 0
Workbooks.Add
For i = 1 To wbCount
r = r + 1
cValue = GetInfoFromClosedFile(FolderName, wbList(i), "BAI", "B3")
Cells(r, 1).Formula = wbList(i)
Cells(r, 2).Formula = cValue
Next i
End Sub

Private Function GetInfoFromClosedFile(ByVal wbPath As String, _
wbName As String, wsName As String, cellRef As String) As Variant
Dim arg As String
GetInfoFromClosedFile = ""
If Right(wbPath, 1) <> "\" Then wbPath = wbPath & "\"
If Dir(wbPath & "\" & wbName) = "" Then Exit Function
arg = "'" & wbPath & "[" & wbName & "]" & _
wsName & "'!" & Range(cellRef).Address(True, True, xlR1C1)
On Error Resume Next
GetInfoFromClosedFile = ExecuteExcel4Macro(arg)
End Function

但是问题是，这只能把一个单元格复制粘贴过去，但我想粘贴一列过去，比如：(B2：B23)全都站过去，不知道要怎么改啊。。。

跪求
自己还写了一个这样的代码，但是一直报错，能改好也成。。目的达到就行，跪谢啊

Sub 批量CP()
Dim i As Integer
For i = 1 To 51

Windows("i.xls").Activate
Sheets("BAI").Select
Range("B3:E23").Select
Application.CutCopyMode = False
Selection.Copy

Windows("批量 CP.xlsx").Activate
Sheets("BAI").Select
Range("Bi").Select
Selection.PasteSpecial Paste:=xlPasteValuesAndNumberFormats, Operation:= _
xlNone, SkipBlanks:=False, Transpose:=True
Next
End Sub

Answer 1

cValue = GetInfoFromClosedFile(FolderName, wbList(i), "BAI", "B3")
Cells(r, 1).Formula = wbList(i)
Cells(r, 2).Formula = cValue
这三句替换成下面的代码
Cells(r, 1).Formula = wbList(i)
For j = 2 To 23
cValue = GetInfoFromClosedFile(FolderName, wbList(i), "BAI", "B" & j)
Cells(r, j).Formula = cValue
Next j

Answer 2

你俩的代码差了几条街。。。。
你复制列要怎么粘贴。。
都贴到一列还是
站到所有列？

追问

就是，

把“1.xls”的“BAI”表的“B3：B23”复制,选择性粘贴（值和数字格式，并转置）到“批量 CP.xlsx”的“BAI”表的“B1：V1”

同理，
把“2.xls”的“BAI”表的“B3：B23”复制,选择性粘贴（值和数字格式，并转置）到“批量 CP.xlsx”的“BAI”表的“B2：V2”
......等等
大侠帮帮忙啊~~！

追答

转置的。。。

Sub Macro1()
Dim FolderName As String, wbName As String, r As Long
Dim wbList() As String, wbCount As Integer, i As Integer

'这个文件夹的路径你自己改
path1 = "C:\批处理"
FolderName = path1

wbCount = 0
wbName = Dir(FolderName & "\" & "*.xlsx")
While wbName ""
If wbName "CP.xlsx" Then
wbCount = wbCount + 1
ReDim Preserve wbList(1 To wbCount)
wbList(wbCount) = path1 & wbName
wbName = Dir
End If
Wend
If wbCount = 0 Then Exit Sub

r = 1
Dim Wb1, Wb2
Dim Sht1 As Worksheet, Sht2 As Worksheet
Set Wb1 = Workbooks.Open(path1 & "CP.xlsx")
Set Sht1 = Wb1.Sheets("sheet1")
r = 0
For i = 1 To wbCount
Set Wb2 = GetObject(wbList(i))
Set Sht2 = Wb2.Sheets("sheet1")
Sht2.Range("B2:B23").Copy
Sht1.Cells(r, 2).PasteSpecial Paste:=xlPasteValues, Transpose:=True
r = r + 1
Wb2.Save
Wb2.Close
Next i
End Sub

Answer 3

Sub 批量CP()
Dim i As Integer
For i = 1 To 51

'＝＝＝＝或者这里加入打开工作簿的代码
Windows(i & ".xls").Activate
Sheets("BAI").Select
Range("B3:E23").Select
Application.CutCopyMode = False
Selection.Copy
'＝＝＝＝这里加入关闭工作簿的代码

Windows("批量 CP.xlsx").Activate
Sheets("BAI").Select
Range("Bi").Select
Selection.PasteSpecial Paste:=xlPasteValuesAndNumberFormats, Operation:= _
xlNone, SkipBlanks:=False, Transpose:=True
Next
End Sub
这个宏在执行前应该要将工作簿1.xls-51.xls都先打开，批量CP.xlsx也要先打开，不然执行时仍然会报错的。或者按我上面的指示，在注释处加入相应代码，可减少预先打开1-51工作簿的麻烦。