[已解决]麻烦高手帮忙改一下程序

mengcao888

Sub 按钮3_Click()
    Dim x As Integer
    Dim y As Integer
    Dim i As Long
    Dim j As Long
y = 6
While Sheet1.Cells(y, 1) <> ""
x = 6
While Sheet2.Cells(x, 1) <> ""
If Sheet2.Cells(x, 5) = Sheet1.Cells(y, 4) Then
j = Sheet3.Cells.Rows.Count
i = Sheet3.Range("a" & j).End(xlUp).Row + 1
Sheet3.rang("a" & i) = Sheet1.Cells(y, 3)
Sheet3.rang("b" & i) = Sheet1.Cells(y, 4)
Sheet3.rang("c" & i) = Sheet1.Cells(y, 5)
Sheet3.rang("d" & i) = Sheet1.Cells(y, 6)
Sheet3.rang("e" & i) = Sheet1.Cells(y, 7)
Sheet3.rang("f" & i) = Sheet2.Cells(x, 5)
Sheet3.rang("g" & i) = Sheet1.Cells(y, 10)
End If
x = x + 1
Wend
y = y + 1
Wend
End Sub
这段程序运行不了，不知是什么原因？

最佳答案

月排行榜 / 总排行榜

老司机带带我

2016-8-16 14:00

你的sheet1和sheet2中没有配号编码相同的，代码如下：

1. Sub 配号()
   
2.     Dim d, arr(), i%, n%
   
3.     Set d = CreateObject("Scripting.Dictionary")
   
4.     With Sheet1
   
5.         n = .Cells(.Rows.Count, 4).End(xlUp).Row
   
6.         For i = 6 To n
   
7.             d.Add .Cells(i, 4).Value, i - 5
   
8.             ReDim Preserve arr(1 To 7, 1 To i - 5)
   
9.             arr(1, i - 5) = .Cells(i, 3)
   
10.             arr(2, i - 5) = .Cells(i, 4)
    
11.             arr(3, i - 5) = .Cells(i, 5)
    
12.             arr(4, i - 5) = .Cells(i, 6)
    
13.             arr(5, i - 5) = .Cells(i, 7)
    
14.             arr(6, i - 5) = .Cells(i, 10)
    
15.         Next
    
16.     End With
    
17.     With Sheet2
    
18.         n = .Cells(.Rows.Count, 2).End(xlUp).Row
    
19.         For i = 6 To n
    
20.             If d.Exists(.Cells(i, 2).Value) Then arr(7, d(.Cells(i, 2).Value)) = .Cells(i, 5)
    
21.         Next
    
22.     End With
    
23.     x = 1
    
24.     For Each k In d.keys
    
25.         If arr(7, d(k)) <> "" Then
    
26.             x = x + 1
    
27.             Sheet3.Cells(x, 1).Resize(1, 7) = Application.WorksheetFunction.Transpose(Application.Index(arr, 0, d(k)))
    
28.         End If
    
29.     Next
    
30. End Sub

复制代码

跳转到最佳答案楼层

老司机带带我

你的sheet1和sheet2中没有配号编码相同的，代码如下：

1. Sub 配号()
   
2.     Dim d, arr(), i%, n%
   
3.     Set d = CreateObject("Scripting.Dictionary")
   
4.     With Sheet1
   
5.         n = .Cells(.Rows.Count, 4).End(xlUp).Row
   
6.         For i = 6 To n
   
7.             d.Add .Cells(i, 4).Value, i - 5
   
8.             ReDim Preserve arr(1 To 7, 1 To i - 5)
   
9.             arr(1, i - 5) = .Cells(i, 3)
   
10.             arr(2, i - 5) = .Cells(i, 4)
    
11.             arr(3, i - 5) = .Cells(i, 5)
    
12.             arr(4, i - 5) = .Cells(i, 6)
    
13.             arr(5, i - 5) = .Cells(i, 7)
    
14.             arr(6, i - 5) = .Cells(i, 10)
    
15.         Next
    
16.     End With
    
17.     With Sheet2
    
18.         n = .Cells(.Rows.Count, 2).End(xlUp).Row
    
19.         For i = 6 To n
    
20.             If d.Exists(.Cells(i, 2).Value) Then arr(7, d(.Cells(i, 2).Value)) = .Cells(i, 5)
    
21.         Next
    
22.     End With
    
23.     x = 1
    
24.     For Each k In d.keys
    
25.         If arr(7, d(k)) <> "" Then
    
26.             x = x + 1
    
27.             Sheet3.Cells(x, 1).Resize(1, 7) = Application.WorksheetFunction.Transpose(Application.Index(arr, 0, d(k)))
    
28.         End If
    
29.     Next
    
30. End Sub

复制代码

mengcao888

刚才拷贝代码试运行了一下，很好用。谢谢“老司机带带我”。

mengcao888

请问高手， d.Add .Cells(i, 4).Value, i - 5这句后面的“i - 5”参数的作用？谢谢！

laoau138

老司机带带我 发表于 2016-8-16 14:00
你的sheet1和sheet2中没有配号编码相同的，代码如下：

用VBA字典提速这个速度太慢

http://www.excelpx.com/thread-424313-1-1.html