ExcelHome技术论坛

 找回密码
 免费注册

QQ登录

只需一步,快速开始

   
EH云课堂-专业的职场技能充电站 永久免费,网表让Excel秒变数据库 Excel服务器-会Excel,做管理系统 Excel Home精品图文教程库
Excel不给力? 何不试试FoxTable! Excel函数公式学习大典 高效办公必会的Office实战技巧 免费下载Excel行业应用视频
300集Office 2010微视频教程 Tableau-数据可视化工具 ExcelHome出品 - VBA代码宝免费下载 13门Excel免费公开课任你学
你的Excel 2010实战技巧学习锦囊 欲罢不能, 过目难忘的 Office 新界面 免费的Excel考勤计算系统
查看: 470|回复: 15

[求助] 这个谁会做?VBA实现,有鲜花!

[复制链接]

TA的精华主题

TA的得分主题

发表于 2018-8-9 17:43 | 显示全部楼层 |阅读模式
文件内代码作废!

提取圆圈中关键字所在列的内容

提取圆圈中关键字所在列的内容

最终效果

最终效果

666.rar

253.91 KB, 下载次数: 17

文件在这里

TA的精华主题

TA的得分主题

发表于 2018-8-9 17:55 | 显示全部楼层
Sub lkyy()
strfile = Application.GetOpenFilename("EXCEL文档(*.xl*),", , "请选择记录文件")
If strfile = "" Then Exit Sub
With Workbooks.Open(strfile)
    ar = .Sheets(1).Range("a1").CurrentRegion
    .Close 0
End With
ReDim br(1 To 1000, 1 To 2)
For i = 2 To UBound(ar)
    If Len(ar(i, 5)) Then
        For j = 0 To UBound(Split(ar(i, 5), ","))
            n = n + 1
            br(n, 1) = ar(i, 2)
            br(n, 2) = Split(ar(i, 5), ",")(j)
        Next
    End If
Next
Cells.ClearContents
Range("a1").Resize(n, 2) = br
End Sub

6666.zip

245.84 KB, 下载次数: 10

评分

参与人数 1鲜花 +2 收起 理由
约定的童话 + 2 优秀作品

查看全部评分

TA的精华主题

TA的得分主题

 楼主| 发表于 2018-8-9 18:03 | 显示全部楼层
凌空一羽 发表于 2018-8-9 17:55
Sub lkyy()
strfile = Application.GetOpenFilename("EXCEL文档(*.xl*),", , "请选择记录文件")
If strfi ...

6666,大神,那个(i,5)这种能改成关键字吗?因为列数不固定,有时候在Z列有时候在E列,反正就是不固定那种,前面那个(i,2)也是

TA的精华主题

TA的得分主题

发表于 2018-8-9 18:05 | 显示全部楼层
BOM清单,看来又是一个搞SMT行业的人士,其实有好多现成的,比如於成有写过一个EXCEL生成YAMAHA\JUKI\松下的EXCEL宏。。。还带BOM与CAD合并的功能哦。。。

TA的精华主题

TA的得分主题

发表于 2018-8-9 18:09 | 显示全部楼层
约定的童话 发表于 2018-8-9 18:03
6666,大神,那个(i,5)这种能改成关键字吗?因为列数不固定,有时候在Z列有时候在E列,反正就是不固定 ...

Sub lkyy()
strfile = Application.GetOpenFilename("EXCEL文档(*.xl*),", , "请选择记录文件")
If strfile = "" Then Exit Sub
With Workbooks.Open(strfile)
    ar = .Sheets(1).Range("a1").CurrentRegion
    L元件品号 = .Sheets(1).Rows(1).Find("元件品号", , , xlWhole).Column
    L位置 = .Sheets(1).Rows(1).Find("位置", , , xlWhole).Column
    .Close 0
End With
ReDim br(1 To 1000, 1 To 2)
For i = 2 To UBound(ar)
    If Len(ar(i, L位置)) Then
        For j = 0 To UBound(Split(ar(i, L位置), ","))
            n = n + 1
            br(n, 1) = ar(i, L元件品号)
            br(n, 2) = Split(ar(i, L位置), ",")(j)
        Next
    End If
Next
Cells.ClearContents
Range("a1").Resize(n, 2) = br
End Sub


66666.zip

246.15 KB, 下载次数: 8

评分

参与人数 1鲜花 +2 收起 理由
约定的童话 + 2 太强大了

查看全部评分

TA的精华主题

TA的得分主题

 楼主| 发表于 2018-8-9 18:17 | 显示全部楼层
kings12333 发表于 2018-8-9 18:05
BOM清单,看来又是一个搞SMT行业的人士,其实有好多现成的,比如於成有写过一个EXCEL生成YAMAHA\JUKI\松下 ...

哈哈,这都让你看出来了,你说的那个试过了,不通用,还是自己做的实用一点!

TA的精华主题

TA的得分主题

 楼主| 发表于 2018-8-9 18:49 | 显示全部楼层
凌空一羽 发表于 2018-8-9 18:09
Sub lkyy()
strfile = Application.GetOpenFilename("EXCEL文档(*.xl*),", , "请选择记录文件")
If str ...

大神,我把代码关键字改了,为啥导入另外一个文件就不行了啊?
https://pan.baidu.com/s/1QpqXabNpKkMJf11V2Yl6ZQ文件在这里

TA的精华主题

TA的得分主题

发表于 2018-8-9 20:07 | 显示全部楼层
约定的童话 发表于 2018-8-9 18:49
大神,我把代码关键字改了,为啥导入另外一个文件就不行了啊?
https://pan.baidu.com/s/1QpqXabNpKkMJf ...

Sub lkyy()
strfile = Application.GetOpenFilename("EXCEL文档(*.xl*),", , "请选择记录文件")
If strfile = "" Then Exit Sub
With Workbooks.Open(strfile)
    ar = .Sheets(1).UsedRange
    L元件品号 = .Sheets(1).Rows(1).Find("编号", , , xlWhole).Column
    L位置 = .Sheets(1).Rows(1).Find("位号", , , xlWhole).Column
    .Close 0
End With
ReDim br(1 To 1000, 1 To 2)
For i = 2 To UBound(ar)
    If Len(ar(i, L位置)) Then
        If Right(ar(i, L位置), 1) = "," Then x = Left(ar(i, L位置), Len(ar(i, L位置)) - 1) Else x = ar(i, L位置)
        For j = 0 To UBound(Split(x, ","))
            n = n + 1
            br(n, 1) = ar(i, L元件品号)
            br(n, 2) = Split(ar(i, L位置), ",")(j)
        Next
    End If
Next
Cells.ClearContents
Range("a1").Resize(n, 2) = br
End Sub

评分

参与人数 1鲜花 +2 收起 理由
约定的童话 + 2 值得肯定

查看全部评分

TA的精华主题

TA的得分主题

发表于 2018-8-9 20:13 | 显示全部楼层
约定的童话 发表于 2018-8-9 18:49
大神,我把代码关键字改了,为啥导入另外一个文件就不行了啊?
https://pan.baidu.com/s/1QpqXabNpKkMJf ...

见附件………………

gft5rgvdf.zip

70.58 KB, 下载次数: 11

TA的精华主题

TA的得分主题

发表于 2018-8-9 20:46 | 显示全部楼层
  1. Sub fyExcelVBA2()

  2. Application.DisplayAlerts = False
  3. Application.ScreenUpdating = False
  4. Dim arr, brr(), i%, j%, n%
  5. Dim path1$, pathName$
  6. path1 = ThisWorkbook.path
  7. pathName = "常规BOM.xls"

  8. With Workbooks.Open(path1 & "" & pathName)
  9. arr = .Sheets(1).Range("a1").CurrentRegion
  10. .Close 0
  11. End With

  12. For i = 1 To UBound(arr, 2)
  13.    If arr(1, i) = "元件品号" Then m = i
  14.    If arr(1, i) = "位置" Then mm = i
  15. Next i

  16. ReDim brr(1 To UBound(arr) * 3, 1 To 2)
  17.   For i = 2 To UBound(arr)
  18.   If Len(arr(i, m)) Then
  19.      For j = 0 To UBound(Split(arr(i, mm), ","))
  20.       n = n + 1
  21.       brr(n, 1) = arr(i, m)
  22.       brr(n, 2) = Split(arr(i, mm), ",")(j)
  23.      Next j
  24.   End If
  25.   Next i
  26. With Sheets("BOM文件")
  27.    .Cells.ClearContents
  28.    .Range("a1").Resize(UBound(brr), UBound(brr, 2)) = brr
  29. End With
  30. Application.DisplayAlerts = True
  31. Application.ScreenUpdating = True

  32. End Sub

复制代码

评分

参与人数 1鲜花 +2 收起 理由
YZC51 + 2

查看全部评分

您需要登录后才可以回帖 登录 | 免费注册

本版积分规则

关注官方微信,每天学会一个新技能

手机版|关于我们|联系我们|ExcelHome

GMT+8, 2018-12-17 09:33 , Processed in 0.115019 second(s), 20 queries , Gzip On, MemCache On.

Powered by Discuz! X3.4

© 2001-2017 Wooffice Inc.

   

沪公网安备 31011702000001号 沪ICP备11019229号

本论坛言论纯属发表者个人意见,任何违反国家相关法律的言论,本站将协助国家相关部门追究发言者责任!     本站特聘法律顾问:徐怀玉律师 李志群律师

快速回复 返回顶部 返回列表