如果按分组别贴值到总表

chenzhenyi

各位老师，如下图所示，想将group1和group2的内容复制到左边的总表，但是只能实现一个组合的转移，望各位赐教，谢谢

Sub mov()
For j = 3 To 6
For k = 9 To 10
  If Cells(3, j) = Cells(3, k) Then GoSub ee
Next k, j
Exit Sub
ee:
For n = 4 To 7
For m = 4 To 5
  If Cells(n, "b") = Cells(m, "h") Then
  Cells(n, j) = Cells(m, k)
End If
Next m, n
Return
End Sub

moonlit123

你的Group2 在 cells(7,k)
不满足条件，当然不会执行。

Sub mov()
For j = 3 To 6
For k = 9 To 10
  If Cells(3, j) = Cells(3, k) Then GoSub ee
  If Cells(3, j) = Cells(7, k) Then GoSub ee2
Next k, j
Exit Sub
ee:
For n = 4 To 7
For m = 4 To 5
  If Cells(n, "b") = Cells(m, "h") Then
  Cells(n, j) = Cells(m, k)
End If
Next m, n
Return
ee2:
For n = 4 To 7
For m = 8 To 9
  If Cells(n, "b") = Cells(m, "h") Then
  Cells(n, j) = Cells(m, k)
End If
Next m, n
Return
End Sub

deadzlq

PQ参考解法

chenzhenyi

moonlit123 发表于 2019-9-6 23:25
你的Group2 在 cells(7,k)
不满足条件，当然不会执行。

谢谢指教，但是如果group 有100多个，有没有些简单点的方法阿？

moonlit123

chenzhenyi 发表于 2019-9-7 12:09
谢谢指教，但是如果group 有100多个，有没有些简单点的方法阿？

有很多思路。

比如你现在的数据是3x3范围数据，不利于按行和按列查找匹配。
建议先用vba调整为 按行索引的 数据3-4列， 然后再查找匹配进你前面的总表里。

如果没有重复值，可以用数组+字典提高效率。

建议你上传具体附件（比如弄个group10）再讨论。

Sub mov()
Dim d As Object, arr(), brr(), i, j

Set d = CreateObject("Scripting.Dictionary") '字典
arr = Range("H3:J" & Cells(Rows.Count, 8).End(xlUp).Row).Value  'arr为H列到J列数组
brr = Range("B3:F" & Cells(Rows.Count, 2).End(xlUp).Row).Value  'brr为B列到F列数组

For i = 1 To UBound(arr) - 2                   '把arr数组内H列和查找Group所在行的数据（比如I3和J3），组合为关键词，装入字典key内（字典不重复，若有重复值关键词，以最后一个出现数据为准）
If InStr(arr(i, 1), "Group") > 0 Then            
'按Group为批次，每批次有4个key和item数据
   d(arr(i + 1, 1) & arr(i, 2)) = arr(i + 1, 2)
   d(arr(i + 1, 1) & arr(i, 3)) = arr(i + 1, 3)
   d(arr(i + 2, 1) & arr(i, 2)) = arr(i + 2, 2)
   d(arr(i + 2, 1) & arr(i, 3)) = arr(i + 2, 3)
End If
Next i

For i = 2 To UBound(brr)
For j = 2 To 5
If d.exists(brr(i, 1) & brr(1, j)) Then brr(i, j) = d(brr(i, 1) & brr(1, j))      
'字典匹配关键词，若匹配，则把对应的item填入数组brr所对应位置
Next j
Next i
  Range("B3:F" & Cells(Rows.Count, 2).End(xlUp).Row) = brr   
'单元格赋值，把处理完的brr数组数据填充入对应位置的单元格内

End Sub

test2.zip (13.67 KB, 下载次数: 1)

2019-9-8 22:26 上传

点击文件名下载附件

一把小刀闯天下

Option Explicit

Sub test()
  Dim arr, i, j, k, t, p, m
  arr = Range("h3:j" & Cells(Rows.Count, "h").End(xlUp).Row)
  ReDim brr(UBound(arr, 1) / 2, 4)
  For i = 1 To UBound(arr, 1)
    If Left(arr(i, 1), 5) = "Group" Then
      p = i
    ElseIf Len(arr(i, 1)) Then
      m = m + 1
      brr(m, 0) = arr(i, 1)
      brr(m, Val(Mid(arr(p, 2), 2))) = arr(i, 2)
      brr(m, Val(Mid(arr(p, 3), 2))) = arr(i, 3)
    End If
  Next
  brr(0, 0) = "Sum"
  For i = 1 To 4
    brr(0, i) = "C" & i
  Next
  For i = 1 To m - 1
    For j = i + 1 To m
      If brr(i, 0) > brr(j, 0) Then
        For k = 0 To UBound(brr, 2)
          t = brr(i, k): brr(i, k) = brr(j, k): brr(j, k) = t
        Next
      End If
    Next
  Next
  [b3].Resize(m + 1, UBound(brr, 1) + 1) = brr
End Sub

chenzhenyi

我自己也研究了一套。。。

lsc900707

chenzhenyi 发表于 2019-9-15 21:38
我自己也研究了一套。。。

数据多的话没有数组快！