如何提取不同年份不同月份文件夹中指定的行列数数据

天道酬勤y · 发表于 2017-2-17 13:26

现在的情况是在文件夹中有2016-2017年(实际我要做2013-2017年)每个月的文件夹下包括两个分厂的工作簿,(每一个分厂的某一个产品每个月表结构是一样的)现在指定包含"动力厂"的关键字和动力厂工作簿中的"A"产品工作表指定行列数就将所有数据都过来,
请问要怎么实现(如果指定洗选厂B产品也可以实现另外一个分厂数据统计)

成本分析设计.rar (627.12 KB, 下载次数: 18)

补充内容 (2017-2-23 16:16):
格式在后重新设计了下

天道酬勤y · 发表于 2017-2-23 15:46

本帖最后由天道酬勤y 于 2017-2-23 15:52 编辑

成本分析设计.rar (932.3 KB, 下载次数: 6)

2017-2-23 15:51 上传
点击文件名下载附件
最新新格式

opiona 发表于 2017-2-23 15:09

大神厉害啊,但是好像有一点差异,现在是产品下是提取出来的产品,我想xx厂下面是厂,产品下面是产品,具体见图谢谢

原先的

需要的是这个格式的

现在的效果

季茉 · 发表于 2017-2-17 13:36

应该可以用数据透视表向导做多表透视

天道酬勤y · 发表于 2017-2-17 13:39

季茉发表于 2017-2-17 13:36
应该可以用数据透视表向导做多表透视

不行很多合并单元格,用VBA才行,我想用VBA把需要的列全部复制出来,再用透视表

天道酬勤y · 发表于 2017-2-17 14:09

请问有老师帮忙解答下吗

天道酬勤y · 发表于 2017-2-21 15:44

本帖最后由天道酬勤y 于 2017-2-23 17:06 编辑

大神救救我啊,格式重新设计了下取xx厂和xx产品

格式

成本分析设计.rar (932.3 KB, 下载次数: 1)

天道酬勤y · 发表于 2017-2-22 09:58

踩踩人气急寻大师

天道酬勤y · 发表于 2017-2-22 11:16

蓝桥大师帮帮我

天道酬勤y · 发表于 2017-2-23 10:36

再次求救大师

opiona · 发表于 2017-2-23 15:09

Sub Opiona()
'禁止系统刷屏?触发其他事件等
'On Error Resume Next '// 发生错误，自动执行下一句，就是忽略错误
Application.ScreenUpdating = False '//关闭屏幕刷新
Application.DisplayAlerts = False '//关闭系统提示
Application.EnableEvents = False '//禁止触发其他事件
t = Timer '//开始时间
Set SHX = Worksheets("动力厂A产品台账")
SHX.Range("A2:G1048576").ClearContents
STRNAME = SHX.Range("M4").Value
SHEETNAME = SHX.Range("M5").Value
KSH = SHX.Range("M6").Value
JSH = SHX.Range("M7").Value
ICOUNT = JSH - KSH - 1
COUNTCOL = SHX.Range("M100").End(3).Row - 7 + 2
FileArr = FileAllArr(ThisWorkbook.Path, "*" & STRNAME & "*.xls?", ThisWorkbook.Name, True, False)
For I = 0 To UBound(FileArr)
STRMONTH = Mid(GetPathFromFileName(FileArr(I)), 1, InStr(GetPathFromFileName(FileArr(I)), STRNAME) - 1)
Set WB = Workbooks.Open(FileArr(I))
Set SHW = WB.Sheets(SHEETNAME)
ReDim ARR(1 To ICOUNT, 1 To COUNTCOL)
For IROW = 1 To ICOUNT
ARR(IROW, 1) = STRMONTH
ARR(IROW, 2) = STRNAME
For ICOL = 3 To COUNTCOL
ARR(IROW, ICOL) = SHW.Range(SHX.Range("M" & ICOL - 3 + 8).Value & IROW + KSH - 1).Value
Next
Next
WB.Close False '//保存
LASTROW = SHX.Range("A1048576").End(3).Row + 1
SHX.Range("A" & LASTROW).Resize(UBound(ARR, 1), UBound(ARR, 2)) = ARR '//（0 TO X)的数组行列都要+1，(1 TO X) 的不要
Next
Application.EnableEvents = True '// '//恢复触发其他事件
Application.ScreenUpdating = True '//恢复屏幕刷新
Application.DisplayAlerts = True '//恢复系统提示
MsgBox "符合條件的文件個數： " & UBound(FileArr) + 1 & vbCrLf & vbCrLf & "一共用时：" & Format(Timer - t, "#0.0000") & " 秒", , "北极狐提示!!" '//提示所用时间
End Sub

复制代码

opiona · 发表于 2017-2-23 15:11

完整代碼見附件：

成本分析设计.rar (637.11 KB, 下载次数: 19)

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

[求助] 如何提取不同年份不同月份文件夹中指定的行列数数据