VB把一个Excel中的部分数据Copy到另一个Excel表中

概述注：在View -> Toolbar -> View 下调出编辑，可以看到“Comment Block” Shift + F8 调试下一行 Alt +　F8 调出宏 字符串，数值在定义之后，可以直接赋值 Workbooks 集合包含 Microsoft Excel 中所有当前打开的 Workbook 对象。 application.transpose 转置 WorksheetFunction.tr

注：在VIEw -> Toolbar -> VIEw 下调出编辑，可以看到“Comment Block”

Shift + F8 调试下一行

Alt +　F8 调出宏

字符串，数值在定义之后，可以直接赋值

Workbooks集合包含 Microsoft Excel 中所有当前打开的Workbook对象。

application.transpose 转置

WorksheetFunction.transpose

找值

http://zhIDao.baIDu.com/question/180864693.HTML

下面是最终版本，能实现按年份匹配的

Sub Mycopy()

Dim n As Integer
Dim companyList As Range
Dim companyname As Object
Dim SourceBook As Workbook
Dim SourceSheet As Worksheet
Dim myrange As String

n = 2

ThisWorkbook.Activate
Set companyList = Range("B2:B214")


For Each companyname In companyList
Path = "C:\Users\WilliamDong\DropBox\数据\EXCEL\" & companyname & ".xlsx"

If Dir(Path) <> "" Then

Set mydictionary = CreateObject("Scripting.Dictionary")
Set SourceBook = Workbooks.Open(Path,True)
Set SourceSheet = SourceBook.Worksheets(1)
For i = 2 To 9 Step 1 ' C2:C9 所需数据的年份范围
If SourceSheet.Range("C" & i) <> "" Then
mydictionary.Add SourceSheet.Range("C" & i).Value,SourceSheet.Range("L" & i).Value

End If
Next i

dic_keys = mydictionary.keys
dic_items = mydictionary.items

' 下面遍历字典，把值拿出来赋给另一个Excel表中对应的位置E2:L2,对应2005~~2012
For j = 0 To mydictionary.Count - 1
Dim indexnum As String

Select Case dic_keys(j)
Case 2005
indexnum = "E" & n
Case 2006
indexnum = "F" & n
Case 2007
indexnum = "G" & n
Case 2008
indexnum = "H" & n
Case 2009
indexnum = "I" & n
Case 2010
indexnum = "J" & n
Case 2011
indexnum = "K" & n
Case 2012
indexnum = "L" & n
End Select


ThisWorkbook.Worksheets(1).Range(indexnum) = dic_items(j)
Next

SourceBook.Close False
Else

End If

n = n + 1

Next companyname








End Sub

最终的（没能实现按不同年份匹配）

Sub Mycopy()

Dim n As Integer
Dim companyList As Range
Dim companyname As Object
Dim SourceBook As Workbook
Dim SourceSheet As Worksheet
Dim myrange As String

n = 2

ThisWorkbook.Activate
Set companyList = Range("B2:B214")


For Each companyname In companyList
Path = "C:\Users\WilliamDong\DropBox\数据\EXCEL\" & companyname & ".xlsx"

If Dir(Path) <> "" Then

Set SourceBook = Workbooks.Open(Path,True)
Set SourceSheet = SourceBook.Worksheets(1)
RANGE_ = SourceSheet.Range("L2:L9")

myrange = "E" & n & ":" & "L" & n

ThisWorkbook.Activate
ThisWorkbook.Worksheets(1).Range(myrange) = WorksheetFunction.Transpose(RANGE_) '写入数据


SourceBook.Close False
Else

End If

n = n + 1

Next companyname

End Sub

之前（1）

在Excel表1中写入如下宏

Sub copyData()


Dim r1 As Range
Dim r2 As Range
Dim w As Workbook
ThisWorkbook.Activate
Set r1 = ThisWorkbook.Sheets(1).[a1]
Set r2 = ThisWorkbook.Sheets(1).[c1]

Set w = Workbooks.Open(ThisWorkbook.Path & "\Test2.xlsx") ‘Test2是另一个Excel表
w.Sheets(1).[b1] = r1
w.Sheets(1).[b2] = r2
w.Save
w.Close

End Sub

之前（2）

Sub Mycopy()

Dim FSO As Object
Dim SourceFolder As Object
Dim fileItem As Object
Dim fileItemToUse As Object
Dim SourceFoldername As String
Dim n As Integer
Dim myrange As String


n = 2

SourceFoldername = "C:\Users\William\DropBox\数据\EXCEL"
Set FSO = CreateObject("Scripting.fileSystemObject")
Set SourceFolder = FSO.GetFolder(SourceFoldername)


For Each fileItem In SourceFolder.files


'下面就可接着写打开文件读取数据再写入的语句了,如下:
fn = fileItem
Workbooks.Open filename:=fn
Worksheets(1).Select '假设你读取SHEET1的数据
RANGE_ = Range("L2:L9") '需要数据的区域,自己修改
ThisWorkbook.Activate '这个是新表的文件名,自己修改下
Worksheets(1).Select '打开第几个文件就选择SHEET几,如果没有可用ADD代码添加


myrange = "E" & n & ":" & "L" & n


Range(myrange) = RANGE_ '写入数据
Workbooks(2).Close
n = n + 1
'End If
Next fileItem


End Sub

底下是网上参考

'这段代码是读取一个文件夹下的所有文件,也可以根据扩展名筛选其它格式的. '有了文件名,就是打开文件,获得每个文件的SHEET名字.然后写到你想要的地方 Sub Macro1() Dim myDialog As fileDialog,ofile As Object,strname As String,n As Integer Dim FSO As Object,myFolder As Object,myfiles As Object,Dim fn  as StringSet myDialog = Application.fileDialog(msofileDialogFolderPicker) n = 1 With myDialog If .Show <> -1 Then Exit Sub Set FSO = CreateObject("Scripting.fileSystemObject") '这是文件夹选择,点选到你存放文件的那个 Set myFolder = FSO.GetFolder(.Initialfilename) Set myfiles = myFolder.files For Each ofile In myfiles strname = UCase(ofile.name) strname = VBA.Right(strname,3) If strname = "xls" Or strname = "XLS" Then '这是扩展名选择 '下面就可接着写打开文件读取数据再写入的语句了,如下: fn = myFolder & "\" & ofile.name Workbooks.Open filename:=fn Worksheets(1).Select '假设你读取SHEET1的数据 RANGE_ = Range("A2:F50") '需要数据的区域,自己修改 windows("外部表格数据自动导入.xls").Activate '这个是新表的文件名,自己修改下 Worksheets(n).Select '打开第几个文件就选择SHEET几,如果没有可用ADD代码添加 Range("a2:f5") = RANGE_ '写入数据 Workbooks(2).Close n = n + 1 End If Next End With End Sub

总结

以上是内存溢出为你收集整理的VB把一个Excel中的部分数据Copy到另一个Excel表中全部内容，希望文章能够帮你解决VB把一个Excel中的部分数据Copy到另一个Excel表中所遇到的程序开发问题。

如果觉得内存溢出网站内容还不错，欢迎将内存溢出网站推荐给程序员好友。