6月5/6日 Excel函数实战技巧精粹 300集Office 2010微视频教程
5月7日 Excel VBA开发实战 高效办公必会的Office实战技巧
5月6日 Excel透视表实战秘技 网易云课堂-Excel数据透视表应用大全
Excel数据处理与分析实战技巧第1季
查看: 284|回复: 2

VBA实战开发第五期-第四课作业贴

[复制链接]
发表于 2018-5-16 22:22:36 | 显示全部楼层 |阅读模式
积极交作业  互相学习
回复

使用道具 举报

发表于 2018-5-16 22:51:27 | 显示全部楼层
  1. Sub 数据关联()
  2. Dim arr, brr, crr, drr, myarr, mybrr
  3. Dim i%, j%, jj%, k%, kk%, p%, pp%, n%
  4.     With Sheet1
  5.         arr = WorksheetFunction.Transpose(.Range("a1:j64")) '薪资工资
  6.         brr = WorksheetFunction.Transpose(.Range("k1:t15")) '岗位工资
  7.         crr = WorksheetFunction.Transpose(.Range("u1:z15")) '基础绩效工资
  8.         drr = Sheet2.Range("c4:f23")
  9.     End With
  10.     ReDim myarr(1 To UBound(drr), 1 To 1)
  11.     ReDim mybrr(1 To UBound(drr), 1 To 2)
  12.     For i = 1 To UBound(drr)
  13.         For j = 1 To UBound(brr) Step 2
  14.             If drr(i, 1) = brr(j, 2) Then
  15.                 For jj = 2 To UBound(brr, 2)
  16.                     If drr(i, 2) = brr(j, jj) Then
  17.                         n = n + 1
  18.                         myarr(n, 1) = brr(j + 1, jj)
  19.                         GoTo line1
  20.                     End If
  21.                 Next jj
  22.             End If
  23.         Next j
  24. line1:
  25.         For k = 1 To UBound(arr) Step 2
  26.             If drr(i, 1) = arr(k, 2) Then
  27.                 For kk = 5 To UBound(arr, 2)
  28.                     If drr(i, 4) = arr(k, kk) Then
  29.                         mybrr(n, 1) = arr(k + 1, kk)
  30.                         GoTo line2
  31.                     End If
  32.                 Next kk
  33.             End If
  34.         Next k
  35. line2:
  36.         For p = 1 To UBound(crr) Step 2
  37.             If Left(drr(i, 1), 1) = Left(crr(p, 2), 1) Then
  38.                 For pp = 5 To UBound(crr, 2)
  39.                     If Left(crr(p, pp), 1) = Left(drr(i, 2), 1) Then
  40.                         mybrr(n, 2) = crr(p + 1, pp)
  41.                         GoTo line3
  42.                     ElseIf Val(Mid(drr(i, 2), 2, 2)) = crr(p, pp) Then
  43.                         mybrr(n, 2) = crr(p + 1, pp)
  44.                         GoTo line3
  45.                     End If
  46.                 Next pp
  47.             End If
  48.         Next p
  49. line3:
  50.     Next i
  51.     Sheet2.Range("e4").Resize(UBound(myarr, 1)) = myarr
  52.     Sheet2.Range("g4").Resize(UBound(mybrr), 2) = mybrr
  53. End Sub
复制代码


回复 支持 反对

使用道具 举报

发表于 2018-5-18 14:35:27 | 显示全部楼层
  1. Sub 简化格式()
  2.     Sheet11.[a1].CurrentRegion.ClearContents
  3.     Dim arr(), brr(), crr, drr(1 To 2000, 1 To 3)
  4.     Dim i As Long, j As Long, k As Long, a As Long, b As Long
  5.     arr = Sheet2.[a1].CurrentRegion.Value
  6.     ReDim brr(1 To UBound(arr) * (UBound(arr, 2) - 1), 1 To 3)
  7.     drr(1, 1) = "时间"
  8.     drr(1, 2) = "轮训人员"
  9.     drr(1, 3) = "科室"
  10.     a = 1
  11.     b = 2
  12.     For j = 2 To UBound(arr, 2)
  13.         For i = 2 To UBound(arr)
  14.             brr(a, 2) = arr(i, j)
  15.             crr = Split(brr(a, 2), ".") '对科室人员进行分割得出的数组
  16.             For k = 0 To UBound(crr) - LBound(crr)
  17.                 If crr(k) <> "" Then
  18.                     drr(b, 1) = arr(i, 1)
  19.                     drr(b, 2) = crr(k)
  20.                     drr(b, 3) = arr(1, j)
  21.                     b = b + 1
  22.                 End If
  23.             Next
  24.             a = a + 1
  25.         Next
  26.     Next
  27.     Sheet11.[a1].Resize(2000, 3) = drr
  28.     Sheet11.[a1].CurrentRegion.Sort key1:=Range("b1"), order1:=xlDescending, key2:=Range("a1"), order2:=xlAscending, Header:=1 '排序
  29.     Sheet11.[a1].CurrentRegion.RemoveDuplicates Columns:=Array(1, 2, 3), Header:=xlYes '去重复
  30. End Sub
  31. Sub 数据关联()
  32.     Dim arr(), brr(), crr(), drr()
  33.     Dim i As Long, j As Long, k As Long
  34.     Dim flag As Boolean
  35.     arr = Sheet1.Range("a1:j64")
  36.     brr = Sheet1.Range("k1:T15")
  37.     crr = Sheet1.Range("u1:z15")
  38.     drr = Sheet2.Range("a3:i23")
  39.     For i = 2 To UBound(drr)
  40.         For k = 1 To UBound(brr, 2)
  41.         flag = False
  42.             If drr(i, 3) = brr(2, k) Then
  43.                 For j = 5 To UBound(brr)
  44.                     If drr(i, 4) = "股级" Then
  45.                         drr(i, 5) = 0
  46.                     Else
  47.                         If drr(i, 4) = brr(j, k) Then
  48.                             flag = True
  49.                             drr(i, 5) = brr(j, k + 1)
  50.                         End If
  51.                     End If
  52.                     If flag = True Then Exit For
  53.                 Next
  54.                 If flag = True Then Exit For
  55.             End If
  56.         Next
  57.       
  58.         For k = 1 To UBound(arr, 2)
  59.         flag = False
  60.             If drr(i, 3) = arr(2, k) Then
  61.                 For j = 5 To UBound(arr)
  62.                     If drr(i, 6) = arr(j, k) Then
  63.                         flag = True
  64.                         drr(i, 7) = arr(j, k + 1)
  65.                     End If
  66.                     If flag = True Then Exit For
  67.                 Next
  68.                 If flag = True Then Exit For
  69.             End If
  70.         Next
  71.    
  72.         For k = 1 To UBound(crr, 2)
  73.         flag = False
  74.             If Left(drr(i, 3), 2) = crr(2, k) Then
  75.                 For j = 5 To UBound(crr)
  76.                     If drr(i, 4) = "股级" Then
  77.                         drr(i, 8) = 1610
  78.                     Else
  79.                         If Val(Mid(drr(i, 4), 2, 2)) = crr(j, k) Then
  80.                             flag = True
  81.                             drr(i, 8) = crr(j, k + 1)
  82.                         End If
  83.                     End If
  84.                     If flag = True Then Exit For
  85.                 Next
  86.                 If flag = True Then Exit For
  87.             End If
  88.         Next
  89.     Next
  90.     Sheet2.[a3].Resize(UBound(drr), UBound(drr, 2)) = drr
  91. End Sub
复制代码
回复 支持 反对

使用道具 举报

您需要登录后才可以回帖 登录 | 入学

本版积分规则

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