各位老师们，请教一下inputbox中的问题

pvppk

想请教一下，在inputbox根据一个条件查询并返回一个值，附件中有说明，麻烦各位老师帮我一个忙，不胜感激 新建 Microsoft Office Excel 工作表.rar (14.04 KB, 下载次数: 7)

2013-5-21 21:32 上传

点击文件名下载附件

grf1973

1. Sub tt()
   
2.     a = InputBox(prompt:="请输入商品归类编号", Title:="操作提示")
   
3.     With Sheet1
   
4.         .UsedRange.Interior.ColorIndex = 0
   
5.         r = .[c65536].End(3).Row
   
6.         For i = 2 To r
   
7.             If .Cells(i, 3) = a Then
   
8.                 If .Cells(i, 6) <> "" Then .Cells(i, 1).Interior.ColorIndex = 6
   
9.             End If
   
10.         Next
    
11.     End With
    
12. End Sub

复制代码

pvppk

grf1973 发表于 2013-5-22 09:28

老师您好，如果希望将 商品名称复制到sheet2中，并标黄，应该怎么写这个代码呢？ 我试了好多次都不行

grf1973

1. Sub tt()
   
2.     a = InputBox(prompt:="请输入商品归类编号", Title:="操作提示")
   
3.     With Sheet1
   
4.         .UsedRange.Interior.ColorIndex = 0
   
5.         Set xrng = .[a1].Resize(1, 6)
   
6.         r = .[c65536].End(3).Row
   
7.         For i = 2 To r
   
8.             If .Cells(i, 3) = a Then
   
9.                 If .Cells(i, 6) <> "" Then
   
10.                     .Cells(i, 1).Interior.ColorIndex = 6
    
11.                     n = n + 1
    
12.                     Set xrng = Union(xrng, .Cells(i, 1).Resize(1, 6))
    
13.                 End If
    
14.             End If
    
15.         Next
    
16.     End With
    
17.     If n >= 1 Then
    
18.         Sheet2.UsedRange.Clear
    
19.         xrng.Copy Sheet2.[a1]
    
20.         Sheet2.Select
    
21.     End If
    
22. End Sub
    

复制代码

pvppk

grf1973 发表于 2013-5-22 13:50

老师，请帮我看一下这个附件，在A表格中的工程中 如何添加语句可实现 以上效果？（在A表格中输入客户编号后，如Z列有备注，则在B表格的B列中标黄，并弹出一个MSGBOX提示查看备注）
求助.rar (117.86 KB, 下载次数: 6)

2013-5-22 15:42 上传

点击文件名下载附件

grf1973

把你的程序小改了一下。其中复制数据的注释掉了，自己按需要加进去吧。

1. Sub omg1()
   
2.     Dim c As Range, t, wb As Workbook, r&, i&, arr, firstAddress$
   
3.     t = InputBox("请输入一个客户编号")
   
4.     If t = "" Then Exit Sub
   
5.     On Error Resume Next
   
6.     Application.ScreenUpdating = False
   
7.     Set wb = Workbooks("B表格.xlsx")
   
8.     If wb Is Nothing Then
   
9.         Set wb = Workbooks.Open(ThisWorkbook.Path & "\B表格.xlsx")
   
10.         ThisWorkbook.Activate
    
11.     End If
    
12.     On Error GoTo 0
    
13.     r = wb.Sheets(1).[b65536].End(xlUp).Row
    
14.     arr = [a1].CurrentRegion
    
15.     For i = 2 To UBound(arr)
    
16.         If CStr(arr(i, 4)) = t Then
    
17.                 r = r + 1: n = n + 1
    
18.                 With wb.Sheets(1)
    
19.               '      .Cells(r, 5) = arr(i, 8)
    
20.                     .Cells(r, 2) = arr(i, 2)
    
21.                '     .Cells(r, 6) = arr(i, 9)
    
22.                '     .Cells(r, 7) = arr(i, 10)
    
23.               '       .Cells(r, 25) = arr(i, 26)
    
24.                      If arr(i, 26) <> "" Then .Cells(r, 2).Interior.ColorIndex = 6
    
25.                 End With
    
26.          End If
    
27.     Next
    
28.     If n = 0 Then MsgBox "没有查到该客户，请重新输入": Exit Sub
    
29.     Application.ScreenUpdating = True
    
30.    
    
31. End Sub

复制代码

pvppk

grf1973 发表于 2013-5-22 19:48
把你的程序小改了一下。其中复制数据的注释掉了，自己按需要加进去吧。

非常感谢~！！学习了