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

来源：互联网发布：淘宝母婴用品好做吗编辑：程序博客网时间：2024/06/05 09:18

注：在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, 0, 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

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

之前（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

0 0