求VBA高手,把工作簿的特定区域,复制粘贴到新工作簿中。
已经实现了的如下:将读取一个文件夹内所有工作簿中工作表Sheet1上单元格A1中的值到一个新工作簿中。SubMacro1()DimFolderNameAsString,w...
已经实现了的如下:
将读取一个文件夹内所有工作簿中工作表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 展开
将读取一个文件夹内所有工作簿中工作表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 展开
3个回答
展开全部
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
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
2013-10-07 · 知道合伙人软件行家
关注
展开全部
你俩的代码差了几条街。。。。
你复制列要怎么粘贴。。
都贴到一列还是
站到所有列?
你复制列要怎么粘贴。。
都贴到一列还是
站到所有列?
追问
就是,
把“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
已赞过
已踩过<
评论
收起
你对这个回答的评价是?
展开全部
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工作簿的麻烦。
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工作簿的麻烦。
已赞过
已踩过<
评论
收起
你对这个回答的评价是?
推荐律师服务:
若未解决您的问题,请您详细描述您的问题,通过百度律临进行免费专业咨询