[已解决]求助批量合并数据

07mickey · 发表于 2012-12-23 03:44

各位高手们：我现在需要把文件中的除了汇总之外的表格中的第四列提取到汇总表格中，实际中在在同一个文件夹下的工作薄有上百个，每个表中有将近800*8的数据，自己水平有限，实在是弄不出来，求指点。。。压缩包中并不是实际工作中的文件，只是作为一个演示，谢谢大家。

最佳答案

月排行榜 / 总排行榜

hwc2ycy

2012-12-23 13:39

Option Explicit
Sub 提取数据2()
'---------------------------------------------------------------------------------------
' Procedure : 提取数据
' Author : hwc2ycy
' Date : 2012/12/23
' Purpose :
'---------------------------------------------------------------------------------------
Dim app As Object 'object,EXCEL实例
Dim arr '数组
Dim iRow& '数据所在行
Dim Filename$, Path$ '文件名，路径
On Error Resume Next
Application.ScreenUpdating = False '关闭刷屏
Path = ThisWorkbook.Path & Application.PathSeparator
'遍在文件
Filename = Dir(Path & "*.xls*", vbDirectory + vbHidden + vbNormal + vbReadOnly + vbSystem)
If Len(Filename) > 0 Then
Set app = CreateObject("excel.application") '创建对象
'避免打开时运行宏
app.AutomationSecurity = msoAutomationSecurityForceDisable
app.DisplayAlerts = False '不显示错误
End If
Do While Len(Filename) > 0
'Debug.Print Filename
If Not Filename Like "*" & ThisWorkbook.Name & "*" Then ' 避免打开本工作簿
'Debug.Print Filename & "已打开"
With app.Workbooks.Open(Path & Filename, False, True)
If Err.Number <> 0 Then MsgBox Filename & "打开失败": Err.Clear: GoTo error
With .Worksheets(1)
iRow = .Cells(65536, 1).End(xlUp).Row
arr = .Range("d1:d" & iRow) '读取第4列数据
End With
.Close False
End With
iRow = Cells(65536, 1).End(xlUp).Row '因为是03的格式，所以没有用ROWS.COUNT
If iRow > 1 Then iRow = iRow + 1
Range("a" & iRow).Resize(UBound(arr)) = arr '写入汇总表格
End If
error: Filename = Dir() '遍历
Loop
app.AutomationSecurity = msoAutomationSecurityByUI
app.DisplayAlerts = True
Set app = Nothing
Application.ScreenUpdating = True
MsgBox "提取完成"
End Sub

复制代码

重新改了下。

跳转到最佳答案楼层

hwc2ycy · 发表于 2012-12-23 10:08

每个只有SHEET1里的数据要提取嘛？

hwc2ycy · 发表于 2012-12-23 11:00

本帖最后由 hwc2ycy 于 2012-12-23 11:05 编辑

汇总.rar (18.71 KB, 下载次数: 30)

hwc2ycy · 发表于 2012-12-23 11:02

本帖最后由 hwc2ycy 于 2012-12-23 11:04 编辑

Option Explicit
Sub 提取数据()
'---------------------------------------------------------------------------------------
' Procedure : 提取数据
' Author : hwc2ycy
' Date : 2012/12/23
' Purpose :
'---------------------------------------------------------------------------------------
Dim app As New Excel.Application 'app变量
Dim arr '数组
Dim iRow& '数据所在行
Dim Filename$, Path$ '文件名，路径
On Error Resume Next
Application.ScreenUpdating = False '关闭刷屏
'避免打开时运行宏
app.AutomationSecurity = msoAutomationSecurityForceDisable
app.DisplayAlerts = False
Path = ThisWorkbook.Path & Application.PathSeparator
'遍在文件
Filename = Dir(Path & "*.xls*", vbDirectory + vbHidden + vbNormal + vbReadOnly + vbSystem)
Do While Len(Filename) > 0
'Debug.Print Filename
If Not Filename Like "*" & ThisWorkbook.Name & "*" Then ' 避免打开本工作簿
'Debug.Print Filename & "已打开"
With app.Workbooks.Open(Path & Filename, False, True)
If Err.Number <> 0 Then MsgBox Filename & "打开失败": GoTo error
With .Worksheets(1)
iRow = .Cells(65536, 1).End(xlUp).Row
arr = .Range("d1:d" & iRow) '读取第4列数据
End With
.Close False
End With
iRow = Cells(65536, 1).End(xlUp).Row '因为是03的格式，所以没有用ROWS.COUNT
If iRow > 1 Then iRow = iRow + 1
Range("a" & iRow).Resize(UBound(arr)) = arr '写入汇总表格
End If
error: Filename = Dir() '遍历
Loop
app.AutomationSecurity = msoAutomationSecurityByUI
app.DisplayAlerts = True
Set app = Nothing
Application.ScreenUpdating = True
MsgBox "提取完成"
End Sub

复制代码

hwc2ycy · 发表于 2012-12-23 13:39

这个最佳答案由 hwc2ycy 给出，感谢 hwc2ycy 的回答。

单击隐藏图章

Option Explicit
Sub 提取数据2()
'---------------------------------------------------------------------------------------
' Procedure : 提取数据
' Author : hwc2ycy
' Date : 2012/12/23
' Purpose :
'---------------------------------------------------------------------------------------
Dim app As Object 'object,EXCEL实例
Dim arr '数组
Dim iRow& '数据所在行
Dim Filename$, Path$ '文件名，路径
On Error Resume Next
Application.ScreenUpdating = False '关闭刷屏
Path = ThisWorkbook.Path & Application.PathSeparator
'遍在文件
Filename = Dir(Path & "*.xls*", vbDirectory + vbHidden + vbNormal + vbReadOnly + vbSystem)
If Len(Filename) > 0 Then
Set app = CreateObject("excel.application") '创建对象
'避免打开时运行宏
app.AutomationSecurity = msoAutomationSecurityForceDisable
app.DisplayAlerts = False '不显示错误
End If
Do While Len(Filename) > 0
'Debug.Print Filename
If Not Filename Like "*" & ThisWorkbook.Name & "*" Then ' 避免打开本工作簿
'Debug.Print Filename & "已打开"
With app.Workbooks.Open(Path & Filename, False, True)
If Err.Number <> 0 Then MsgBox Filename & "打开失败": Err.Clear: GoTo error
With .Worksheets(1)
iRow = .Cells(65536, 1).End(xlUp).Row
arr = .Range("d1:d" & iRow) '读取第4列数据
End With
.Close False
End With
iRow = Cells(65536, 1).End(xlUp).Row '因为是03的格式，所以没有用ROWS.COUNT
If iRow > 1 Then iRow = iRow + 1
Range("a" & iRow).Resize(UBound(arr)) = arr '写入汇总表格
End If
error: Filename = Dir() '遍历
Loop
app.AutomationSecurity = msoAutomationSecurityByUI
app.DisplayAlerts = True
Set app = Nothing
Application.ScreenUpdating = True
MsgBox "提取完成"
End Sub

复制代码

重新改了下。

07mickey · 发表于 2012-12-23 15:52

hwc2ycy 发表于 2012-12-23 13:39
重新改了下。

班班好棒啊~我要继续再看一下~~~

hwc2ycy · 发表于 2012-12-23 21:26

Option Explicit
Sub 提取数据3()
'---------------------------------------------------------------------------------------
' Procedure : 提取数据
' Author : hwc2ycy
' Date : 2012/12/23
' Purpose :
'---------------------------------------------------------------------------------------
Dim app As Object 'object,EXCEL实例
Dim arr '数组
Dim iRow&, iCol& '数据所在行
Dim Filename$, Path$ '文件名，路径
On Error Resume Next
Application.ScreenUpdating = False '关闭刷屏
Path = ThisWorkbook.Path & Application.PathSeparator
'遍在文件
Filename = Dir(Path & "*.xls*", vbDirectory + vbHidden + vbNormal + vbReadOnly + vbSystem)
If Len(Filename) > 0 Then
Set app = CreateObject("excel.application") '创建对象
'避免打开时运行宏
app.AutomationSecurity = msoAutomationSecurityForceDisable
app.DisplayAlerts = False '不显示错误
End If
Do While Len(Filename) > 0
'Debug.Print Filename
If Not Filename Like "*" & ThisWorkbook.Name & "*" Then ' 避免打开本工作簿
'Debug.Print Filename & "已打开"
With app.Workbooks.Open(Path & Filename, False, True)
If Err.Number <> 0 Then MsgBox Filename & "打开失败": Err.Clear: GoTo error
iCol = iCol + 1
With .Worksheets(1)
iRow = .Cells(65536, 1).End(xlUp).Row
arr = .Range("d1:d" & iRow) '读取第4列数据
End With
.Close False
End With
iRow = Cells(65536, iCol).End(xlUp).Row '因为是03的格式，所以没有用ROWS.COUNT
If iRow > 1 Then iRow = iRow + 1
Cells(iRow, iCol).Resize(UBound(arr)) = arr '写入汇总表格
End If
error: Filename = Dir() '遍历
Loop
app.AutomationSecurity = msoAutomationSecurityByUI
app.DisplayAlerts = True
Set app = Nothing
Application.ScreenUpdating = True
MsgBox "提取完成"
End Sub

复制代码

分列存数据。

dicky_MM · 发表于 2013-3-23 22:45

07mickey 发表于 2012-12-23 15:52
班班好棒啊~我要继续再看一下~~~

好多个语句，我应该看哪个为准呢？能发一个给我吗？

		自动登录	找回密码
密码			注册