Excel精英培训网

 找回密码
 注册
数据透视表40+个常用小技巧,让你一次学会!
楼主: kmcla

[已解决]字典问题,跟据对应项,输出对应值

[复制链接]
发表于 2017-1-9 09:23 | 显示全部楼层
看你的附件迷糊啦!2个表的数据大都对不上号!
行和列你搞清楚没有??
excel精英培训的微信平台,每天都会发送excel学习教程和资料。扫一扫明天就可以收到新教程
回复

使用道具 举报

 楼主| 发表于 2017-1-9 10:05 | 显示全部楼层
zjdh 发表于 2017-1-9 09:23
看你的附件迷糊啦!2个表的数据大都对不上号!
行和列你搞清楚没有??

我用数组做是,取红表路线名&桩号是一个数组1,宽度一个数组2,厚度一个数组3
在绿表中,取路线名&桩号,看在数组1中的位置
在相应位置=数组2(位置),和数组1一样50米取个数
在相应位置=数组3(位置),数组1不一样100米取个数
回复

使用道具 举报

 楼主| 发表于 2017-1-9 10:26 | 显示全部楼层
kmcla 发表于 2017-1-9 10:05
我用数组做是,取红表路线名&桩号是一个数组1,宽度一个数组2,厚度一个数组3
在绿表中,取路线名&桩号 ...

红表数据是全的。
绿表选择性取数
回复

使用道具 举报

 楼主| 发表于 2017-1-9 10:30 | 显示全部楼层
  Sub 垫宽厚()


   Dim d, k, js, e1(1 To 10000), e2(1 To 10000), e3(1 To 10000)
   js = Int(Sheets("垫原").Cells(600000, 1).End(xlUp).Row / 50) + 1
  ' Set d = CreateObject("Scripting.Dictionary")
   'MsgBox js
   m = 1
   For i = 1 To js
     For j = 2 To 17
    If Sheets("垫原").Cells((i - 1) * 50 + 10, j) <> "" Then
   
    e1(m) = Sheets("垫原").Cells((i - 1) * 50 + 4, 14) & Sheets("垫原").Cells((i - 1) * 50 + 6, j)
   e2(m) = Sheets("垫原").Cells((i - 1) * 50 + 10, j)
    e3(m) = Sheets("垫原").Cells((i - 1) * 50 + 13, j)
    m = m + 1
End If


       Next
      Next
         js = Int(Sheets("垫宽").Cells(600000, 1).End(xlUp).Row / 50) + 1
   
  
   For i = 1 To js
     For j = 7 To 37
    If Sheets("垫宽").Cells((i - 1) * 50 + j, 1) <> "" Then
   

a = Sheets("垫宽").Cells((i - 1) * 50 + 4, 11) & Sheets("垫宽").Cells((i - 1) * 50 + j, 1)
    位置 = Application.Match(a, e1, 0)
   
    Sheets("垫宽").Cells((i - 1) * 50 + j, 2) = e2(位置) / 100
    If 提取数字(Sheets("垫宽").Cells((i - 1) * 50 + j, 1)) Mod 100 = 0 Then
     a = Sheets("垫宽").Cells((i - 1) * 50 + 4, 11) & Sheets("垫宽").Cells((i - 1) * 50 + j, 1)
    位置 = Application.Match(a, e1, 0)
   
    Sheets("垫宽").Cells((i - 1) * 50 + j, 8) = e3(位置) / 1
    End If
   
    End If
   
       Next
      Next
      'Set e1 = Nothing
     ' Set e2 = Nothing
    '  Set e3 = Nothing
End Sub
   Sub 基宽厚()

Dim d, k, js, a1(1 To 10000), a2(1 To 10000), a3(1 To 10000), a4(1 To 10000)
js = Int(Sheets("基原").Cells(600000, 1).End(xlUp).Row / 50) + 1
' Set d = CreateObject("Scripting.Dictionary")
'MsgBox js
m = 1
For i = 1 To js
    For j = 2 To 17
        If Sheets("基原").Cells((i - 1) * 50 + 10, j) <> "" Then
            a1(m) = Sheets("基原").Cells((i - 1) * 50 + 3, 9) & Sheets("基原").Cells((i - 1) * 50 + 9, j)
            a2(m) = Sheets("基原").Cells((i - 1) * 50 + 10, j)
            a3(m) = Sheets("基原").Cells((i - 1) * 50 + 12, j)
            a4(m) = Sheets("基原").Cells((i - 1) * 50 + 13, j)
            m = m + 1
        End If
    Next
Next
js = Int(Sheets("基宽").Cells(600000, 1).End(xlUp).Row / 50) + 1
For i = 1 To js
    For j = 7 To 37
        If Sheets("基宽").Cells((i - 1) * 50 + j, 1) <> "" Then
            a = Sheets("基宽").Cells((i - 1) * 50 + 4, 11) & Sheets("基宽").Cells((i - 1) * 50 + j, 1)
            位置 = Application.Match(a, a1, 0)
            Sheets("基宽").Cells((i - 1) * 50 + j, 2) = a2(位置) / 100
            If 提取数字(Sheets("基宽").Cells((i - 1) * 50 + j, 1)) Mod 100 = 0 Then
                a = Sheets("基宽").Cells((i - 1) * 50 + 4, 11) & Sheets("基宽").Cells((i - 1) * 50 + j, 1)
                位置 = Application.Match(a, a1, 0)
                Sheets("基宽").Cells((i - 1) * 50 + j, 8) = a3(位置) / 1
            End If
        End If
    Next
Next
'Set a1 = Nothing
'Set a2 = Nothing
'Set a3 = Nothing
End Sub
我这个能实现。在家里电脑还行,到单位Set a3 = Nothing,不让赋值,只能取消了
回复

使用道具 举报

发表于 2017-1-9 14:02 | 显示全部楼层
本帖最后由 zjdh 于 2017-1-9 14:14 编辑

Sub test()
    Set d = CreateObject("Scripting.Dictionary")
    ARR = Sheets("垫原").Range("A1:Q" & Sheets("垫原").Range("A65536").End(3).Row)
    For I = 1 To UBound(ARR) Step 50
        For J = 2 To 17
            d(ARR(I + 5, J)) = Array(ARR(I + 9, J) / 100, ARR(I + 12, J))
    Next: Next
    ARR = Sheets("垫宽").Range("A1:P" & Sheets("垫宽").Range("A65536").End(3).Row)
    For I = 1 To UBound(ARR) Step 50
        For J = I + 6 To I + 29
            If J > UBound(ARR) Then Exit For
            ARR(J, 2) = "": ARR(J, 8) = ""
            If IsArray(d(ARR(J, 1))) Then
                ARR(J, 2) = d(ARR(J, 1))(0)
                If Right(ARR(J, 1), 2) = "00" Then ARR(J, 8) = d(ARR(J, 1))(1)
            End If
    Next: Next
    Sheets("垫宽").Range("A1").Resize(UBound(ARR), UBound(ARR, 2)) = ARR
End Sub

评分

参与人数 1 +1 收起 理由
kmcla + 1 在帮一下.一下五没做出来

查看全部评分

回复

使用道具 举报

发表于 2017-1-9 14:14 | 显示全部楼层
工作簿1.rar (33.52 KB, 下载次数: 7)

评分

参与人数 1 +1 收起 理由
kmcla + 1 我虽然还没看懂,但是你好牛.比我的短多了.

查看全部评分

回复

使用道具 举报

 楼主| 发表于 2017-1-9 16:40 | 显示全部楼层


桩号 d(ARR(i + 5, J)) ,不是唯一的.必须用路线名称控制
大哥我笨,一下五没做出来.
如果上一个数组,和下一个数组,不是都必须ARR,帮我换一个名,我理解不了
Sub tes1t()
    Set d = CreateObject("Scripting.Dictionary")
    ARR = Sheets("垫原").Range("A1:Q" & Sheets("垫原").Range("A65536").End(3).Row)

    For i = 1 To UBound(ARR) Step 50
        For J = 2 To 17
            d(ARR(i + 5, J)) = Array(ARR(i + 9, J) / 100, ARR(i + 12, J))
            MsgBox d(ARR(J, 1))(1)
            'd.Add ARR(i + 3, 14) & (ARR(i + 5, J)), Array(ARR(i + 9, J) / 100, ARR(i + 12, J))
    Next: Next
    ARR = Sheets("垫宽").Range("A1:P" & Sheets("垫宽").Range("A65536").End(3).Row)
    For i = 1 To UBound(ARR) Step 50
        For J = i + 6 To i + 29
            If J > UBound(ARR) Then Exit For
            ARR(J, 2) = "": ARR(J, 8) = ""
           ' If ARR(i + 3, 11) = d(ARR(i + 3, 14)) Then
            If IsArray(d(ARR(J, 1))) Then
                ARR(J, 2) = d(ARR(J, 1))(0)
                If Right(ARR(J, 1), 2) = "00" Then ARR(J, 8) = d(ARR(J, 1))(1)
            End If
           ' End If
    Next: Next
    Sheets("垫宽").Range("A1").Resize(UBound(ARR), UBound(ARR, 2)) = ARR
End Sub

回复

使用道具 举报

发表于 2017-1-9 21:08 | 显示全部楼层
不懂你在说啥

评分

参与人数 1 +1 收起 理由
kmcla + 1 很给力

查看全部评分

回复

使用道具 举报

 楼主| 发表于 2017-1-10 06:19 | 显示全部楼层

我改完了,就加两个(),弄一天.
Sub tedfst()
    Set d = CreateObject("Scripting.Dictionary")
    ARR = Sheets("垫原").Range("A1:Q" & Sheets("垫原").Range("A65536").End(3).Row)
    For I = 1 To UBound(ARR) Step 50
        For J = 2 To 17
            d(ARR(I + 3, 14) & ARR(I + 5, J)) = Array(ARR(I + 9, J) / 100, ARR(I + 12, J))
    Next: Next
    ARR = Sheets("垫宽").Range("A1:P" & Sheets("垫宽").Range("A65536").End(3).Row)
    For I = 1 To UBound(ARR) Step 50
        For J = I + 6 To I + 29
            If J > UBound(ARR) Then Exit For
            ARR(J, 2) = "": ARR(J, 8) = ""
            If IsArray(d(ARR(I + 3, 11) & ARR(J, 1))) Then
                ARR(J, 2) = d(ARR(I + 3, 11) & ARR(J, 1))(0)
                If Right(ARR(J, 1), 2) = "00" Then ARR(J, 8) = d(ARR(I + 3, 11) & ARR(J, 1))(1)
            End If
    Next: Next
    Sheets("垫宽").Range("A1").Resize(UBound(ARR), UBound(ARR, 2)) = ARR
End Sub

回复

使用道具 举报

 楼主| 发表于 2017-1-10 07:58 | 显示全部楼层
Sub dkjkjh()
    Set d = CreateObject("Scripting.Dictionary")
    ARR = Sheets("垫原").Range("A1:Q" & Sheets("垫原").Range("A65536").End(3).Row)
    For i = 1 To UBound(ARR) Step 50
        For j = 2 To 17
            If ARR(i + 5, j) <> "" Then
            d(ARR(i + 3, 14) & ARR(i + 5, j)) = Array(ARR(i + 9, j) / 100, ARR(i + 12, j), (ARR(i + 12, j) - ARR(i + 8, 2)) * 10, (ARR(i + 9, j) / 100 - ARR(i + 1, 1)) * 1000)
            End If
        Next: Next
    ARR = Sheets("垫宽").Range("A1:P" & Sheets("垫宽").Range("A65536").End(3).Row)
    For i = 1 To UBound(ARR) Step 50
        For j = i + 6 To i + 29
            If j > UBound(ARR) Then Exit For
            ARR(j, 2) = "": ARR(j, 8) = ""
            If IsArray(d(ARR(i + 3, 11) & ARR(j, 1))) Then
                Sheets("垫宽").Cells(j, 2) = d(ARR(i + 3, 11) & ARR(j, 1))(0)
                Sheets("垫宽").Cells(j, 5) = d(ARR(i + 3, 11) & ARR(j, 1))(3)
                If Right(ARR(j, 1), 2) = "00" Then
                Sheets("垫宽").Cells(j, 8) = d(ARR(i + 3, 11) & ARR(j, 1))(1)
                Sheets("垫宽").Cells(j, 11) = d(ARR(i + 3, 11) & ARR(j, 1))(2)
               End If
            End If
        Next: Next
      
End Sub

全改完了,学到不少。=左面的是顶,右面是值,可以有多个值,以前以为一个项对就一个值
回复

使用道具 举报

您需要登录后才可以回帖 登录 | 注册

本版积分规则

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

GMT+8, 2024-3-29 15:22 , Processed in 1.033580 second(s), 15 queries , Gzip On, Yac On.

Powered by Discuz! X3.4

Copyright © 2001-2020, Tencent Cloud.

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