[已解决]如何能将若干excel文件按照模板要就汇成一个新表

laye · 发表于 2013-10-16 11:06

本帖最后由 laye 于 2013-10-16 11:39 编辑

如何能将若干excel文件按照模板要就汇成一个新表，已有的excel文件格式是相同的，内容不同且文件个数不定，新生成的excel文件格式固定，无需打印。上传两个附件，求帮助……

最佳答案

月排行榜 / 总排行榜

hwc2ycy

2013-10-16 12:40

新文件模板.rar (12.84 KB, 下载次数: 13)

hwc2ycy · 发表于 2013-10-16 11:16

第一个关键点是文件遍历的问题。
剩下的就很容易了，提取数据。

关于遍历可查下论坛或F1 DIR。

laye · 发表于 2013-10-16 11:40

原有文件存在格式兼容问题可能会打不开，现重新上传了“原有文件”附件。

hwc2ycy · 发表于 2013-10-16 12:26

Sub 数据整理()
Dim strPath As String, strFile As String
Dim arr(1 To 10000, 1 To 6), i As Long
strPath = ThisWorkbook.Path & Application.PathSeparator & Application.PathSeparator
strFile = Dir(strPath & "*.xls")
With Application
.ScreenUpdating = False
.DisplayAlerts = False
.Calculation = xlCalculationManual
End With
Do While Len(strFile)
If strFile <> ThisWorkbook.Name Then
'找到文件后执行的操作
Debug.Print strFile
Call getDate(strPath & strFile, arr, i)
End If
strFile = Dir
Loop
Cells(Rows.Count, 1).End(xlUp).Offset(1).Resize(i, UBound(arr, 2)).Value = arr
With Application
.ScreenUpdating = True
.DisplayAlerts = True
.Calculation = xlCalculationAutomatic
End With
MsgBox "数据整理完成", vbInformation
End Sub
Sub getDate(ByRef strFullName As String, ByRef arr As Variant, ByRef arrSize As Long)
Dim objWbk As Workbook
Dim arrTemp
Dim strCode$, strCompany$
Dim lLastrow As Long
Dim i As Long
Set objWbk = GetObject(strFullName)
With objWbk
With .Worksheets("sheet1")
lLastrow = .Cells(Rows.Count, "b").End(xlUp).Row
If lLastrow > 4 Then
arrTemp = .Range("a5:e" & lLastrow).Value
strCode = Split(.Range("a2").Value, "：")(1)
strCompany = Split(.Range("a3").Value, "：")(1)
For i = LBound(arrTemp) To UBound(arrTemp)
arrSize = arrSize + 1
arr(arrSize, 1) = arrTemp(i, 1)
arr(arrSize, 2) = "'" & strCode
arr(arrSize, 3) = "'" & strCompany
arr(arrSize, 4) = arrTemp(i, 3)
arr(arrSize, 5) = "'" & arrTemp(i, 4)
arr(arrSize, 6) = arrTemp(i, 5)
Next
End If
End With
.Close False
End With
End Sub

复制代码

hwc2ycy · 发表于 2013-10-16 12:38

序列号修正了下，原来引用的分表里的。

Sub 数据整理()
Dim strPath As String, strFile As String
Dim arr(1 To 10000, 1 To 5), i As Long, j As Long
strPath = ThisWorkbook.Path & Application.PathSeparator & Application.PathSeparator
strFile = Dir(strPath & "*.xls")
With Application
.ScreenUpdating = False
.DisplayAlerts = False
.Calculation = xlCalculationManual
End With
Do While Len(strFile)
If strFile <> ThisWorkbook.Name Then
Call getDate(strPath & strFile, arr, i)
End If
strFile = Dir
Loop
Cells(Rows.Count, "b").End(xlUp).Offset(1).Resize(i, UBound(arr, 2)).Value = arr
With Range("a2")
.Value = 1
.AutoFill .Resize(Cells(Rows.Count, "b").End(xlUp).Row - 1), xlFillSeries
End With
With Application
.ScreenUpdating = True
.DisplayAlerts = True
.Calculation = xlCalculationAutomatic
End With
MsgBox "数据整理完成", vbInformation
End Sub
Sub getDate(ByRef strFullName As String, ByRef arr As Variant, ByRef arrSize As Long)
Dim objWbk As Workbook
Dim arrTemp
Dim strCode$, strCompany$
Dim lLastrow As Long
Dim i As Long
Set objWbk = GetObject(strFullName)
With objWbk
With .Worksheets("sheet1")
lLastrow = .Cells(Rows.Count, "b").End(xlUp).Row
If lLastrow > 4 Then
arrTemp = .Range("a5:e" & lLastrow).Value
strCode = Split(.Range("a2").Value, "：")(1)
strCompany = Split(.Range("a3").Value, "：")(1)
For i = LBound(arrTemp) To UBound(arrTemp)
arrSize = arrSize + 1
arr(arrSize, 1) = "'" & strCode
arr(arrSize, 2) = "'" & strCompany
arr(arrSize, 3) = arrTemp(i, 3)
arr(arrSize, 4) = "'" & arrTemp(i, 4)
arr(arrSize, 5) = arrTemp(i, 5)
Next
End If
End With
.Close False
End With
End Sub

复制代码

hwc2ycy · 发表于 2013-10-16 12:40

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

单击隐藏图章

新文件模板.rar (12.84 KB, 下载次数: 13)

laye · 发表于 2013-10-16 13:09

测试OK，完全符合需要，谢谢。

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

[已解决]如何能将若干excel文件按照模板要就汇成一个新表

相关帖子