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

最新推荐文章于 2024-08-13 08:39:15 发布

William_Dong

最新推荐文章于 2024-08-13 08:39:15 发布

阅读量1.8w

点赞数

CC 4.0 BY-SA版权

分类专栏： VB+Excel

本文链接：https://blog.youkuaiyun.com/dongweionly/article/details/23475715

VB+Excel 专栏收录该内容

2 篇文章

订阅专栏

此博客介绍了一个宏脚本，用于批量处理多个Excel文件，通过读取特定年份的数据并整合到另一张工作表中，实现了数据的高效迁移与格式统一。

摘要生成于 C知道，由 DeepSeek-R1 满血版支持，前往体验 >

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