请玄霜老师教我一下吧，谢谢啊，急用的

iuriahz

请玄霜老师赐教啊，还没搞定的问题，万分感激，急用，问题在附件里面

李甲

1. Sub QQ57132899()
   
2. Dim I, J
   
3. AR = [B1:Q14]
   
4. BR = Sheet3.[A1].CurrentRegion
   
5. For I = 1 To UBound(AR)
   
6.     For J = 1 To UBound(AR, 2)
   
7.         If AR(I, J) <> "" Then
   
8.             For K = 2 To UBound(BR)
   
9.                 If AR(I, J) = BR(K, 1) Then
   
10.                     AR(I, J + 1) = BR(K, 2)
    
11.                     AR(I, J + 2) = BR(K, 3)
    
12.                     AR(I, J + 3) = BR(K, 4)
    
13.                     AR(I, J + 4) = ""
    
14.                     AR(I, J + 5) = BR(K, 5)
    
15.                     J = J + 5
    
16.                     Exit For
    
17.                 End If
    
18.             Next
    
19.         End If
    
20.     Next
    
21. Next
    
22. [B37].Resize(UBound(AR), UBound(AR, 2)) = AR
    
23. End Sub

复制代码

iuriahz

不行啊，老师

蓝桥玄霜

1. Sub lqxs()
   
2. Dim Arr, i&, Brr(1 To 5), rng As Range
   
3. Dim d, k, r%, cel As Range, Arr1()
   
4. Set d = CreateObject("Scripting.Dictionary")
   
5. Sheet1.Activate
   
6. Set rng = [b1:o14]
   
7. Arr = Sheet13.[a1].CurrentRegion
   
8. For i = 2 To UBound(Arr)
   
9.     d(Arr(i, 1)) = i
   
10. Next
    
11. For Each cel In rng
    
12.     If cel.Value <> "" Then
    
13.         r = r + 1
    
14.         ReDim Preserve Arr1(1 To r)
    
15.         Arr1(r) = cel.Address
    
16.     End If
    
17. Next
    
18. For i = 1 To r
    
19.     If d.exists(Range(Arr1(i)).Value) Then
    
20.         m = d(Range(Arr1(i)).Value)
    
21.         Brr(1) = Arr(m, 2)
    
22.         Brr(2) = Arr(m, 3)
    
23.         Brr(3) = Arr(m, 4)
    
24.         Brr(5) = Format(Arr(m, 5), "0000")
    
25.         Range(Arr1(i)).Offset(0, 1).Resize(1, 5) = Brr
    
26.         Erase Brr
    
27.     End If
    
28. Next
    
29. End Sub
    

复制代码

iuriahz

玄霜老师代码是对的，但是目标不只是对b1：O14范围内的料号做处理，而是整个工作簿中其他工作页中只要有料号，运行代码后都能有那样的结果，麻烦帮我再改一下吧，万分感谢

fzkoko

试试看，是不是这样？

Sub test()
    Dim rng As Range, d As Object, Arr, i&
    Set d = CreateObject("scripting.dictionary")
    Arr = Sheet13.Range("A1").CurrentRegion
    For i = 2 To UBound(Arr)
        d(Arr(i, 1)) = i
    Next
    Range("B1:Q14").NumberFormatLocal = "@"
    For Each rng In Range("B1:Q14").SpecialCells(xlCellTypeConstants)
        If d.exists(rng.Value) Then
            With Application
                rng.Offset(, 1) = .Index(Arr, d(rng.Value), 2)
                rng.Offset(, 2) = .Index(Arr, d(rng.Value), 3)
                rng.Offset(, 3) = .Index(Arr, d(rng.Value), 4)
                rng.Offset(, 5) = .Index(Arr, d(rng.Value), 5)
            End With

        End If
    Next
End Sub

蓝桥玄霜

请见附件。

iuriahz

谢谢两位老师赐教，可能是我没把问题陈述清楚，我重新把文件补充一下，你们看下，就是运用代码把1,2.。。。等工作页中含有料号的部分，都按照“例图”中的样子把“Material list”中物料号后面的数据抓出来。非常感谢你们，麻烦帮我再改一下代码吧！！！

fzkoko

iuriahz 发表于 2013-3-11 21:22
谢谢两位老师赐教，可能是我没把问题陈述清楚，我重新把文件补充一下，你们看下，就是运用代码把1,2.。。。 ...

Sub test()
    On Error Resume Next
    Dim rng As Range, d As Object, Arr, i&, sht As Worksheet, Shtname
    Set d = CreateObject("scripting.dictionary")
    Arr = Sheets("Material list").Range("A1").CurrentRegion
    For i = 2 To UBound(Arr)
        d(Arr(i, 1)) = i
    Next
    Shtname = Array("Project list", "Material list", "例图")
    For Each sht In Worksheets
        If sht.Name = "Project list" Or sht.Name = "Material list" Or sht.Name = "例图" Then GoTo 100
        For Each rng In sht.Cells.SpecialCells(xlCellTypeConstants)
            If d.exists(rng.Value) Then
                With Application
                    rng.Offset(, 1) = .Index(Arr, d(rng.Value), 2)
                    rng.Offset(, 2) = .Index(Arr, d(rng.Value), 3)
                    rng.Offset(, 3) = .Index(Arr, d(rng.Value), 4)
                    With rng.Offset(, 5)
                        .NumberFormatLocal = "@"
                        .Value = .Index(Arr, d(rng.Value), 5)
                    End With

                End With

            End If
        Next
100:

    Next
End Sub

fzkoko

前面代码有点问题，修改如下：
Sub test()
    On Error Resume Next
    Dim rng As Range, d As Object, Arr, i&, sht As Worksheet, Shtname
    Set d = CreateObject("scripting.dictionary")
    Arr = Sheets("Material list").Range("A1").CurrentRegion
    For i = 2 To UBound(Arr)
        d(Arr(i, 1)) = i
    Next
    For Each sht In Worksheets
        If sht.Name = "Project list" Or sht.Name = "Material list" Or sht.Name = "例图" Then GoTo 100
        For Each rng In sht.Cells.SpecialCells(xlCellTypeConstants)
            If d.exists(rng.Value) Then
                With Application
                    rng.Offset(, 1) = .Index(Arr, d(rng.Value), 2)
                    rng.Offset(, 2) = .Index(Arr, d(rng.Value), 3)
                    rng.Offset(, 3) = .Index(Arr, d(rng.Value), 4)
                    rng.Offset(, 5).NumberFormatLocal = "@"
                    rng.Offset(, 5) = .Index(Arr, d(rng.Value), 5)
                End With

            End If
        Next
100:

    Next
End Sub