设为首页收藏本站
开启辅助访问

Excel精英培训网

 找回密码
 注册
Excel精英培训网»论坛 › Excel 求助区 › Excel VBA开发 › Excel 2003 VBA 问题
数据透视表40+个常用小技巧，让你一次学会！
12345下一页
返回列表 发新帖
查看: 6902|回复: 46

[已解决]Excel 2003 VBA 问题

[复制链接]
spp0063
发表于 2016-11-11 12:28 | 显示全部楼层 |阅读模式
工作中常用的Excel函数公式，全印在一张超大鼠标垫上
本帖最后由 spp0063 于 2016-11-11 16:36 编辑

你好,
因工作需求,我才刚接触VBA,目前我已修改按下按钮字可自动输入批号并搜寻批号并复制至巡检表内,有3个问题想询问大家帮忙!==========================================================================
需求说明:
按下"搜寻按钮",会自动筛选"输入表"A栏所有批号,并自动加入到"巡检表"(不管我的"输入表"内资料有多少批,只要找到相同批号资料,将资料依序补满到"巡检表"的F4:J18储存格内,补满至五格为止(空白跳过不补资料)),所需表格内
(例如:批号为DW0R-17000002-FQC1/DW0R-17000002-0522/DW0R-17000002-FQC, 输入17000002 会自动搜寻三笔资料)
==========================================================================
1.若程式想修改为最后一栏改成只要抓两笔资料,即输入表内的AV:AU(巡检表F18:G18),需修改哪些地方
注:程式已设定范围 --> Set ToRange = Range("F4:J18") 当我抓取资料会抓取到范围外的资料这是为何?
2.若我想将资料移动位置(例如往上移动, 往下移动),修改程式码那?
3.机台编号我一直无法抓到, 是公式用错吗?
4.因搜寻批号资料太多,程式是否可以改成更快速?
==========================================================================
程式码 :
Private Sub CommandButton1_Click()
Dim R As Integer, C As Integer, O As Integer
Dim SC_Area As Range, AreaRange As Range, ToRange As Range, FRange As Range, x
Dim tmpArr()
Set ToRange = Range("F4:J18")
ReDim tmpArr(ToRange.Rows.Count - 1, 4)
'ReDim
ToRange.ClearContents
With Worksheets("輸入表").UsedRange
x = InputBox("請輸入批號 [ Please enter Lot ID ]", "請輸入批號 [Please enter Lot ID ]")
Sheets("巡檢表").Range("I2") = "DW01-" & x
Set FRange = .Range("E6:AV6")
.AutoFilter
.AutoFilter Field:=1, Criteria1:="????-" & x & "-????", Operator:=xlOr, _
Criteria2:="????-" & x & "-???"
For R = 0 To ToRange.Rows.Count - 1
C = 0
For Each SC_Area In .Offset(FRange.Row - 1, FRange.Column - 1 + (R * 3)).Resize(, 3) _
.SpecialCells(xlCellTypeVisible).Areas
For Each AreaRange In SC_Area
If C >= 5 Then
Exit For
ElseIf AreaRange.Text <> "" Then
tmpArr(R, C) = AreaRange.Text
C = C + 1
End If
Next AreaRange
Next SC_Area
Next R
.AutoFilter
End With
ToRange = tmpArr
End Sub
==========================================================================






最佳答案
月排行榜 / 总排行榜
grf1973
2016-11-11 15:06
1、只需重新定义ToRange即可
2、把If n(k) <= 5 Then tmpArr(k, n(k)) = arr(i, j + jj) 改为
    If n(k) <= 3 Then tmpArr(k, n(k)) = arr(i, j + jj)
即为抓取3笔资料
3、代码解释如下：
  1. Private Sub CommandButton1_Click()
  2.     Dim i, j, jj, k, x, LotNo
  3.     Dim ToRange As Range
  4.     Dim tmpArr(), n(), arr
  5.     Set ToRange = Range("F4:J18")
  6.     ReDim tmpArr(1 To ToRange.Rows.Count, 1 To 5)
  7.     ReDim n(1 To ToRange.Rows.Count)     '数组n记录每组数的记录位置
  8.     ToRange.ClearContents
  9.     x = InputBox("請輸入批號 [ Please enter Lot ID ]", "請輸入批號 [Please enter Lot ID ]")
  10.     With Worksheets("輸入表")   '读入数据源
  11.         arr = .Range("a1:av" & .[a65536].End(3).Row)
  12.     End With
  13.     For i = 6 To UBound(arr)
  14.         LotNo = arr(i, 1)   '批号
  15.         If InStr(LotNo, x) > 0 Then   '批号中含输入框内容
  16.             Range("I2") = LotNo    'I2显示为批号（这样vlookup结果就正确了，但当符合条件的有多条记录时，会只显示最后一条记录的批号）
  17.             For j = 5 To 47 Step 3    'E列到AU列
  18.                 k = (j - 2) / 3    '根据源数据的列转换到tmparr的行
  19.                 For jj = 0 To 2   '每列共3列需录入tmpArr（最后一次2列）
  20.                     If j + jj <= UBound(arr, 2) Then    '限定边界（最后一次只计算AU--AV列）
  21.                         If arr(i, j + jj) <> "" Then     '如果数据源需录入的列非空
  22.                             n(k) = n(k) + 1     'tmpArr对应行每组的记录位置+1
  23.                             If n(k) <= 5 Then tmpArr(k, n(k)) = arr(i, j + jj)   '源数据保存到记录位置（最多只保存5个）
  24.                         End If
  25.                     End If
  26.                 Next jj
  27.             Next j
  28.         End If
  29.     Next i
  30.     ToRange = tmpArr    '显示结果
  31. End Sub
复制代码
Excel

VBA.zip

44.54 KB, 下载次数: 4

File

相关帖子

excel精英培训的微信平台，每天都会发送excel学习教程和资料。扫一扫明天就可以收到新教程
回复

使用道具 举报

工作中最常用的函数公式，全印在一张超大的鼠标垫上
zjdh
发表于 2016-11-11 13:28 | 显示全部楼层
工作中常用的Excel函数公式，全印在一张超大鼠标垫上
不是“求教”而是“询问”！
回复

使用道具 举报

grf1973
发表于 2016-11-11 14:08 | 显示全部楼层
工作中最常用的Excel函数公式，全印在一张鼠标垫上
重新用数组改写了一下。
至于机台编号一直无法抓到, 是因为公式里vlookup的是批号的全字符，而[I2]只有部分。

  1. Private Sub CommandButton1_Click()
  2.     Dim i, j, jj, k, x, LotNo
  3.     Dim ToRange As Range
  4.     Dim tmpArr(), n(), arr
  5.     Set ToRange = Range("F4:J18")
  6.     ReDim tmpArr(1 To ToRange.Rows.Count, 1 To 5)
  7.     ReDim n(1 To ToRange.Rows.Count)
  8.     ToRange.ClearContents
  9.     x = InputBox("請輸入批號 [ Please enter Lot ID ]", "請輸入批號 [Please enter Lot ID ]")
  10.     With Worksheets("輸入表")
  11.         arr = .Range("a1:av" & .[a65536].End(3).Row)
  12.     End With
  13.     For i = 6 To UBound(arr)
  14.         LotNo = arr(i, 1)
  15.         If InStr(LotNo, x) > 0 Then
  16.             Range("I2") = LotNo
  17.             For j = 5 To 47 Step 3    'E列到AU列
  18.                 k = (j - 2) / 3
  19.                 For jj = 0 To 2
  20.                     If j + jj <= UBound(arr, 2) Then    '限定边界（最后一次只计算AU--AV列）
  21.                         If arr(i, j + jj) <> "" Then
  22.                             n(k) = n(k) + 1
  23.                             If n(k) <= 5 Then tmpArr(k, n(k)) = arr(i, j + jj)
  24.                         End If
  25.                     End If
  26.                 Next jj
  27.             Next j
  28.         End If
  29.     Next i
  30.     ToRange = tmpArr
  31. End Sub
复制代码
回复

使用道具 举报

spp0063
 楼主| 发表于 2016-11-11 14:37 | 显示全部楼层
本帖最后由 spp0063 于 2016-11-11 15:01 编辑
grf1973 发表于 2016-11-11 14:08
重新用数组改写了一下。
至于机台编号一直无法抓到, 是因为公式里vlookup的是批号的全字符，而只有部分。
...

grf1973 你好,
谢谢快速回复,我才刚接触VBA,仍有问题想请你协助,请参阅下方


1.若我想将资料移动位置(例如往上移动, 往下移动),修改程式码那?(如附件红色位置移至蓝色位置)
注: 只需修改 Set ToRange = Range("F4:J18") 这个范围,还需修改哪些地方?
====================================================================================
2.若程式想修改为每一栏改成固定抓取三笔资料,即输入表内的AV:AU(巡检表F18:G18),需修改哪些地方
====================================================================================3.批号DWOR-17000002-0822 & DWOR-17000002-0822直接抓取会有问题
====================================================================================
4. 可否说明以下程式码的动作
ReDim tmpArr(1 To ToRange.Rows.Count, 1 To 5)
ReDim n(1 To ToRange.Rows.Count)

arr = .Range("a1:av" & .[a65536].End(3).Row)
    End With
    For i = 6 To UBound(arr)
        LotNo = arr(i, 1)
        If InStr(LotNo, x) > 0 Then
            Range("I2") = LotNo
            For j = 5 To 47 Step 3    'E列到AU列
                k = (j - 2) / 3
                For jj = 0 To 2
                    If j + jj <= UBound(arr, 2) Then    '限定?界（最后一次只?算AU--AV列）
                        If arr(i, j + jj) <> "" Then
                            n(k) = n(k) + 1
                            If n(k) <= 5 Then tmpArr(k, n(k)) = arr(i, j + jj)



Thanks!



test.jpg
回复

使用道具 举报

grf1973
发表于 2016-11-11 15:06 | 显示全部楼层    本楼为最佳答案   
1、只需重新定义ToRange即可
2、把If n(k) <= 5 Then tmpArr(k, n(k)) = arr(i, j + jj) 改为
    If n(k) <= 3 Then tmpArr(k, n(k)) = arr(i, j + jj)
即为抓取3笔资料
3、代码解释如下：
  1. Private Sub CommandButton1_Click()
  2.     Dim i, j, jj, k, x, LotNo
  3.     Dim ToRange As Range
  4.     Dim tmpArr(), n(), arr
  5.     Set ToRange = Range("F4:J18")
  6.     ReDim tmpArr(1 To ToRange.Rows.Count, 1 To 5)
  7.     ReDim n(1 To ToRange.Rows.Count)     '数组n记录每组数的记录位置
  8.     ToRange.ClearContents
  9.     x = InputBox("請輸入批號 [ Please enter Lot ID ]", "請輸入批號 [Please enter Lot ID ]")
  10.     With Worksheets("輸入表")   '读入数据源
  11.         arr = .Range("a1:av" & .[a65536].End(3).Row)
  12.     End With
  13.     For i = 6 To UBound(arr)
  14.         LotNo = arr(i, 1)   '批号
  15.         If InStr(LotNo, x) > 0 Then   '批号中含输入框内容
  16.             Range("I2") = LotNo    'I2显示为批号（这样vlookup结果就正确了，但当符合条件的有多条记录时，会只显示最后一条记录的批号）
  17.             For j = 5 To 47 Step 3    'E列到AU列
  18.                 k = (j - 2) / 3    '根据源数据的列转换到tmparr的行
  19.                 For jj = 0 To 2   '每列共3列需录入tmpArr（最后一次2列）
  20.                     If j + jj <= UBound(arr, 2) Then    '限定边界（最后一次只计算AU--AV列）
  21.                         If arr(i, j + jj) <> "" Then     '如果数据源需录入的列非空
  22.                             n(k) = n(k) + 1     'tmpArr对应行每组的记录位置+1
  23.                             If n(k) <= 5 Then tmpArr(k, n(k)) = arr(i, j + jj)   '源数据保存到记录位置（最多只保存5个）
  24.                         End If
  25.                     End If
  26.                 Next jj
  27.             Next j
  28.         End If
  29.     Next i
  30.     ToRange = tmpArr    '显示结果
  31. End Sub
复制代码
回复

使用道具 举报

spp0063
 楼主| 发表于 2016-11-11 15:14 | 显示全部楼层
zjdh 发表于 2016-11-11 13:28
不是“求教”而是“询问”！

不好意思, 我是新手不知道, 下次我会注意的,感谢告知!
回复

使用道具 举报

spp0063
 楼主| 发表于 2016-11-11 16:21 | 显示全部楼层
grf1973 发表于 2016-11-11 15:06
1、只需重新定义ToRange即可
2、把If n(k)

grf1973 你好,
我发现有bug, 当我输入什么批号都会抓取,是否能限制批号内容,类似以下程式码一样
.AutoFilter Field:=1, Criteria1:="????-" & x & "-????", Operator:=xlOr, _
Criteria2:="????-" & x & "-???"

回复

使用道具 举报

grf1973
发表于 2016-11-11 16:36 | 显示全部楼层
把15句条件改成   If LotNo Like "*-" & x & "-*" Then
回复

使用道具 举报

grf1973
发表于 2016-11-11 16:37 | 显示全部楼层
请看附件。

VBA.rar

36.13 KB, 下载次数: 1
回复

使用道具 举报

spp0063
 楼主| 发表于 2016-11-11 16:39 | 显示全部楼层
grf1973 发表于 2016-11-11 16:36
把15句条件改成   If LotNo Like "*-" & x & "-*" Then

谢谢, 已经可以了
回复

使用道具 举报

下一页 »
12345下一页
返回列表 发新帖
高级模式
B Color Image Link Quote Code Smilies
您需要登录后才可以回帖 登录 | 注册

本版积分规则

小黑屋|手机版|Archiver|Excel精英培训 ( 豫ICP备11015029号 )

GMT+8, 2024-4-25 17:59 , Processed in 0.481181 second(s), 12 queries , Gzip On, Yac On.

Powered by Discuz! X3.4

Copyright © 2001-2020, Tencent Cloud.

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