[已解决]VBA实现多工作簿数据整理到一个工作簿内

摩米 · 发表于 2016-11-23 12:14

本帖最后由摩米于 2016-11-24 13:14 编辑

详情在附件内，VBA小白请求老师帮忙解决！
"原始数据"文件里面的工作簿都是下载后没有动过的，点开都是需要启用编辑
批量导入"原始数据"文件夹中所有工作簿数据到"模板"工作簿，并且对应日期
还需要把文本转换成数值

因为每天都需要大量时间来把文本转换为数值，然后复制粘贴，还请老师费心编写一下，万分感谢！

最佳答案

月排行榜 / 总排行榜

苏子龙

2016-11-23 14:07

Sub tt()
Dim filePath As String, shName As String
Dim wbName As String, wb As Workbook, sh As Worksheet
Dim lstRow%, staRow%, mbRow&, i%, n%
Application.ScreenUpdating = False
Sheet1.Range("a2:m65536").ClearContents
filePath = ThisWorkbook.Path & "\原始数据"
wbName = Dir(filePath & "*.xls*")
Do While wbName <> ""
Set wb = Workbooks.Open(filePath & wbName, True, True)
For Each sh In wb.Worksheets
staRow = sh.Range("A:A").Find("关键词").Row + 2
lstRow = sh.Range("a65536").End(3).Row
mbRow = Sheet1.Range("a65536").End(3).Row
arr = sh.Range(Cells(staRow, 1), Cells(lstRow, 13))
n = 0
For i = 1 To UBound(arr)
If arr(i, 1) <> "" Then
n = n + 1
Sheet1.Cells(mbRow + n, 1) = Right(Split(wbName, ".")(0), 10)
Sheet1.Cells(mbRow + n, 2).Resize(, 13) = Application.Index(arr, i)
End If
Next
wb.Close: Set wb = Nothing: Erase arr
Next
wbName = Dir
Loop
Application.ScreenUpdating = True
End Sub

复制代码

试做了下，单元格格式没有设置

跳转到最佳答案楼层

yanhj · 发表于 2016-11-23 13:31

模板里日期有何用？前三列插入一些文件名及表名信息。希望能对你有帮助。

苏子龙 · 发表于 2016-11-23 14:07

Sub tt()
Dim filePath As String, shName As String
Dim wbName As String, wb As Workbook, sh As Worksheet
Dim lstRow%, staRow%, mbRow&, i%, n%
Application.ScreenUpdating = False
Sheet1.Range("a2:m65536").ClearContents
filePath = ThisWorkbook.Path & "\原始数据"
wbName = Dir(filePath & "*.xls*")
Do While wbName <> ""
Set wb = Workbooks.Open(filePath & wbName, True, True)
For Each sh In wb.Worksheets
staRow = sh.Range("A:A").Find("关键词").Row + 2
lstRow = sh.Range("a65536").End(3).Row
mbRow = Sheet1.Range("a65536").End(3).Row
arr = sh.Range(Cells(staRow, 1), Cells(lstRow, 13))
n = 0
For i = 1 To UBound(arr)
If arr(i, 1) <> "" Then
n = n + 1
Sheet1.Cells(mbRow + n, 1) = Right(Split(wbName, ".")(0), 10)
Sheet1.Cells(mbRow + n, 2).Resize(, 13) = Application.Index(arr, i)
End If
Next
wb.Close: Set wb = Nothing: Erase arr
Next
wbName = Dir
Loop
Application.ScreenUpdating = True
End Sub

复制代码

试做了下，单元格格式没有设置

摩米 · 发表于 2016-11-23 14:08

yanhj 发表于 2016-11-23 13:31
模板里日期有何用？前三列插入一些文件名及表名信息。希望能对你有帮助。

日期是我后面还需要对数据进行处理的，是一定需要的。您的代码还没有解决我的问题，不过还是谢谢您

摩米 · 发表于 2016-11-23 14:30

苏子龙发表于 2016-11-23 14:07
试做了下，单元格格式没有设置

非常的好，正是我想要的结果好想快点学会，万分感谢谢谢谢谢！！{:021:}

yanhj · 发表于 2016-11-23 14:42

x = [D65536].End(3).Row 改 x = [E65536].End(3).Row

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