[已解决]VBA唯取一值且引用多列数据汇总，请帮忙！

xhuang

各位大神：

早上好！
VBA唯取一值且引用多列数据汇总，请帮忙！

计划列表 （数据量非常大，有上万列）
唯一值	卷绕设备
18400-004&MO2204060015	华冠圆柱全自动1#
13450-011&SC2204160001	泽源圆柱全自动1#
13450-011&SC2204160001	泽源圆柱全自动2#
13450-011&MO2204210008	泽源圆柱全自动1#
13450-011&MO2204210008	泽源圆柱全自动2#

实现的结果，如下：

实际结果如下：
每一个唯一保留三行合并，后面我需要核算完成情况
这两列需要用VBA帮忙取唯一值		这部份我们用公引用即可
唯一值	机台	项目	日期
18400-004&MO2204060015	华冠圆柱全自动1#	计划	这一部份我用公式引用即可
		实际
		完成率
13450-011&SC2204160001	泽源圆柱全自动1# 泽源圆柱全自动2#	计划
		实际
		完成率
13450-011&MO2204210008	泽源圆柱全自动1# 泽源圆柱全自动2#	计划
		实际
		完成率
备注:  数据量非常大，用函数可以实际，但EXCEL运行太慢太慢了，谢谢！

最佳答案

月排行榜 / 总排行榜

hasyh2008

2022-5-9 11:42

Sub TQ()
  Dim Rs%, I%, Dic
  Dim Arr(), Ky(), It()
  Rs = Sheet1.Cells(Rows.Count, 1).End(xlUp).Row
  Arr = Sheet1.Range("A3:B" & Rs)
  Set Dic = CreateObject("scripting.dictionary")
  For I = 1 To UBound(Arr)
    Dic(Arr(I, 1)) = Dic(Arr(I, 1)) & vbLf & Arr(I, 2)
  Next I
  Ky = Dic.keys
  It = Dic.Items
  With Sheet2
    .Range("A5:B10000") = ""
    For I = 1 To UBound(Ky) + 1
      .Range(Cells(I * 3 + 2, 1), Cells(I * 3 + 4, 1)).Merge
      .Range(Cells(I * 3 + 2, 2), Cells(I * 3 + 4, 2)).Merge
      .Cells(I * 3 + 2, 1) = Ky(I - 1)
      .Cells(I * 3 + 2, 2) = It(I - 1)
    Next I
  End With
End Sub

跳转到最佳答案楼层

hasyh2008

Sub TQ()
  Dim Rs%, I%, Dic
  Dim Arr(), Ky(), It()
  Rs = Sheet1.Cells(Rows.Count, 1).End(xlUp).Row
  Arr = Sheet1.Range("A3:B" & Rs)
  Set Dic = CreateObject("scripting.dictionary")
  For I = 1 To UBound(Arr)
    Dic(Arr(I, 1)) = Arr(I, 2)
  Next I
  Ky = Dic.keys
  It = Dic.Items
  With Sheet2
    For I = 1 To UBound(Ky) + 1
      .Range(Cells(I * 3 + 2, 1), Cells(I * 3 + 4, 1)).Merge
      .Range(Cells(I * 3 + 2, 2), Cells(I * 3 + 4, 2)).Merge
      .Cells(I * 3 + 2, 1) = Ky(I - 1)
      .Cells(I * 3 + 2, 2) = It(I - 1)
    Next I
  End With
End Sub

xhuang

hasyh2008 发表于 2022-5-9 11:04
Sub TQ()
  Dim Rs%, I%, Dic
  Dim Arr(), Ky(), It()

大神好
引用，黄色部门那边有两条，只引用了最后一条，能否两条都引用过来：
还有，每次更新能否将之前先清掉数据，谢谢！


正确为：红色为漏了

hasyh2008

下面的试试看！！

hasyh2008

Sub TQ()
  Dim Rs%, I%, Dic
  Dim Arr(), Ky(), It()
  Rs = Sheet1.Cells(Rows.Count, 1).End(xlUp).Row
  Arr = Sheet1.Range("A3:B" & Rs)
  Set Dic = CreateObject("scripting.dictionary")
  For I = 1 To UBound(Arr)
    Dic(Arr(I, 1)) = Dic(Arr(I, 1)) & vbLf & Arr(I, 2)
  Next I
  Ky = Dic.keys
  It = Dic.Items
  With Sheet2
    .Range("A5:B10000") = ""
    For I = 1 To UBound(Ky) + 1
      .Range(Cells(I * 3 + 2, 1), Cells(I * 3 + 4, 1)).Merge
      .Range(Cells(I * 3 + 2, 2), Cells(I * 3 + 4, 2)).Merge
      .Cells(I * 3 + 2, 1) = Ky(I - 1)
      .Cells(I * 3 + 2, 2) = It(I - 1)
    Next I
  End With
End Sub