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

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

 
 
找值 
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 String
Set 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@H_404_32@
VB把一个Excel中的部分数据Copy到另一个Excel表中

猜你在找的VB相关文章
