注:在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:UsersWilliamDongDropbox数据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:UsersWilliamDongDropbox数据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:UsersWilliamDropbox数据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 (编辑:李大同)
【声明】本站内容均来自网络,其相关言论仅代表作者个人观点,不代表本站立场。若无意侵犯到您的权利,请及时与联系站长删除相关内容!
|