[已解决]麻烦给写个代码,谢谢

WMJQWERR

又来麻烦各位老师给写代码了,先谢过了   详情见附件 工作簿1.rar (11.08 KB, 下载次数: 17)

2017-9-10 19:27 上传

点击文件名下载附件

最佳答案

月排行榜 / 总排行榜

grf1973

2017-9-18 09:35

Sub grf()
    arr = Sheets("采购价").Range("a3:f" & Sheets("采购价").[a65536].End(3).Row)
    Set d = CreateObject("scripting.dictionary")
    For i = 1 To UBound(arr)   '采购价表中，按名称放入字典d，以各行为item
        d(arr(i, 2) & arr(i, 3)) = d(arr(i, 2) & arr(i, 3)) & "," & i
    Next
   
    r = [a65536].End(3).Row
    brr = Range("a3:f" & r)
    Set d1 = CreateObject("scripting.dictionary")
    ReDim crr(1 To UBound(arr), 1 To UBound(arr, 2))
    For i = 1 To UBound(brr)
        x = brr(i, 2) & brr(i, 3)  '名称+单位
        If Not d.exists(x) Then   '如果名称在字典中不存在，本行置空
            For j = 1 To UBound(brr, 2): brr(i, j) = "": Next
        Else
            xrr = Split(d(x), ",")   '取各行中的第1行内容作为本行内容
            ii = xrr(1): d1(Val(ii)) = ""   '字典d1控制已经取用过的行
            For j = 1 To UBound(brr, 2): brr(i, j) = arr(ii, j): Next
            If UBound(xrr) = 1 Then   '如果此名称在采购表中只有1行，直接取用，并在字典中去掉（同时解决基准表和采购价多对一的问题）
                d.Remove (x)
            Else
                xrr(1) = "": d(x) = "," & Join(xrr, ",")    '如果此名称在采购表中超过1行，取用第1行后，去掉第1行（解决基准表和采购价一对多的问题）
            End If
        End If
    Next
    Range("g3").Resize(UBound(brr), UBound(brr, 2)) = brr
            
    For i = 1 To UBound(arr)   '查看字典d1，没有取用过的行放到最下面
        If Not d1.exists(i) Then
            n = n + 1
            For j = 1 To UBound(arr, 2)
                crr(n, j) = arr(i, j)
            Next
        End If
    Next
    Cells(r + 1, "G").Resize(n, UBound(crr, 2)) = crr
End Sub

跳转到最佳答案楼层

WMJQWERR

别沉啊,,沉下去,大师就看不到了哦  我顶

WMJQWERR

又沉了

QCW911

这么多文字

WMJQWERR

QCW911 发表于 2017-9-13 12:09
这么多文字

呵呵,应该是文字太多,太麻烦了哦,怪不得木有大侠问津啊,,,,等晚上我在改一下,,,改的简单一点,在发上来,,,谢谢你了

grf1973

想用ado做的，结果发现一对多，多对一情况比较复杂。只好老老实实用字典做。

1. Sub grf()
   
2.     arr = Sheets("采购价").Range("a3:f" & Sheets("采购价").[a65536].End(3).Row)
   
3.     Set d = CreateObject("scripting.dictionary")
   
4.     For i = 1 To UBound(arr)   '采购价表中，按名称放入字典d，以各行为item
   
5.         d(arr(i, 2)) = d(arr(i, 2)) & "," & i
   
6.     Next
   
7.    
   
8.     r = [a65536].End(3).Row
   
9.     brr = Range("a3:f" & r)
   
10.     Set d1 = CreateObject("scripting.dictionary")
    
11.     ReDim crr(1 To UBound(arr), 1 To UBound(arr, 2))
    
12.     For i = 1 To UBound(brr)
    
13.         x = brr(i, 2)
    
14.         If Not d.exists(x) Then   '如果名称在字典中不存在，本行置空
    
15.             For j = 1 To UBound(brr, 2): brr(i, j) = "": Next
    
16.         Else
    
17.             xrr = Split(d(x), ",")   '取各行中的第1行内容作为本行内容
    
18.             ii = xrr(1): d1(Val(ii)) = ""   '字典d1控制已经取用过的行
    
19.             For j = 1 To UBound(brr, 2): brr(i, j) = arr(ii, j): Next
    
20.             If UBound(xrr) = 1 Then   '如果此名称在采购表中只有1行，直接取用，并在字典中去掉（同时解决基准表和采购价多对一的问题）
    
21.                 d.Remove (x)
    
22.             Else
    
23.                 xrr(1) = "": d(x) = "," & Join(xrr, ",")    '如果此名称在采购表中超过1行，取用第1行后，去掉第1行（解决基准表和采购价一对多的问题）
    
24.             End If
    
25.         End If
    
26.     Next
    
27.     Range("g3").Resize(UBound(brr), UBound(brr, 2)) = brr
    
28.             
    
29.     For i = 1 To UBound(arr)   '查看字典d1，没有取用过的行放到最下面
    
30.         If Not d1.exists(i) Then
    
31.             n = n + 1
    
32.             For j = 1 To UBound(arr, 2)
    
33.                 crr(n, j) = arr(i, j)
    
34.             Next
    
35.         End If
    
36.     Next
    
37.     Cells(r + 1, "G").Resize(n, UBound(crr, 2)) = crr
    
38. End Sub

复制代码

WMJQWERR

grf1973 发表于 2017-9-13 16:14
想用ado做的，结果发现一对多，多对一情况比较复杂。只好老老实实用字典做。

谢谢，大神啊，膜拜中啊、、、、
还得麻烦问一下，能不能把采购价中名称和单位都和基准价格相同 的一行复制过去，，，感觉这次没有考虑单位呢！！！

WMJQWERR

grf1973 发表于 2017-9-13 16:14
想用ado做的，结果发现一对多，多对一情况比较复杂。只好老老实实用字典做。

老师,,,有空的时候给看看啊

grf1973

Sub grf()
    arr = Sheets("采购价").Range("a3:f" & Sheets("采购价").[a65536].End(3).Row)
    Set d = CreateObject("scripting.dictionary")
    For i = 1 To UBound(arr)   '采购价表中，按名称放入字典d，以各行为item
        d(arr(i, 2) & arr(i, 3)) = d(arr(i, 2) & arr(i, 3)) & "," & i
    Next
   
    r = [a65536].End(3).Row
    brr = Range("a3:f" & r)
    Set d1 = CreateObject("scripting.dictionary")
    ReDim crr(1 To UBound(arr), 1 To UBound(arr, 2))
    For i = 1 To UBound(brr)
        x = brr(i, 2) & brr(i, 3)  '名称+单位
        If Not d.exists(x) Then   '如果名称在字典中不存在，本行置空
            For j = 1 To UBound(brr, 2): brr(i, j) = "": Next
        Else
            xrr = Split(d(x), ",")   '取各行中的第1行内容作为本行内容
            ii = xrr(1): d1(Val(ii)) = ""   '字典d1控制已经取用过的行
            For j = 1 To UBound(brr, 2): brr(i, j) = arr(ii, j): Next
            If UBound(xrr) = 1 Then   '如果此名称在采购表中只有1行，直接取用，并在字典中去掉（同时解决基准表和采购价多对一的问题）
                d.Remove (x)
            Else
                xrr(1) = "": d(x) = "," & Join(xrr, ",")    '如果此名称在采购表中超过1行，取用第1行后，去掉第1行（解决基准表和采购价一对多的问题）
            End If
        End If
    Next
    Range("g3").Resize(UBound(brr), UBound(brr, 2)) = brr
            
    For i = 1 To UBound(arr)   '查看字典d1，没有取用过的行放到最下面
        If Not d1.exists(i) Then
            n = n + 1
            For j = 1 To UBound(arr, 2)
                crr(n, j) = arr(i, j)
            Next
        End If
    Next
    Cells(r + 1, "G").Resize(n, UBound(crr, 2)) = crr
End Sub

WMJQWERR

grf1973 发表于 2017-9-18 09:35
Sub grf()
    arr = Sheets("采购价").Range("a3:f" & Sheets("采购价").[a65536].End(3).Row)
    Set  ...

谢谢大神,,完美解决问题