【急急急】VBA如何根据单元格指定值分别复制到对应单元格

yyj1254

如图所示，需要将复制区的数据，按照公司代码进行复制数值，然后粘贴到Q列，不需要筛选，但是需要根据公司代码进行分类。

每家公司复制区数据总行数不同，粘贴区固定4行（固定的模板，如果复制区数据没有4行，粘贴区剩下的几行就是空值）。
如公司代码为20的公司，数据复制区是2行，粘贴区是4行，因此粘贴区会有2行空值；公司代码为60的公司，复制区数据是1行，粘贴区是4行，因此粘贴区会有3行空值

我的思路：用IF赋值，行数用I循环，i=4 to 10000，cells（i,1）从上到下遍历至最后一行，如果公司代码=20，sheets.range("L" & i & ":L" & i + 4).copy sheets.range(Q4:Q7) 然后使用elseif。。。。

但是实际写起来执行不了 应该是哪里有问题 求大神指导！！！

yyj1254

补充：如公司代码为20的数据，原来一共4行数据，复制到粘贴区也是4行数据，但是粘贴的区域跟原来不一样

taller

shiruiqiang

yyj1254

shiruiqiang 发表于 2024-2-14 07:45

C:\Users\wangl\Desktop\微信图片_.png

yyj1254

shiruiqiang 发表于 2024-2-14 07:45

提示下标越界了 如何处理呢

yyj1254

taller 发表于 2024-2-14 03:32

谢谢 但是这个看起来有点复杂 我研究下

shiruiqiang

yyj1254 发表于 2024-2-14 15:43
提示下标越界了 如何处理呢

按照你帖子要求，把79改4

gwjkkkkk

代码审核中，请参考图片。。。

gwjkkkkk

Option Explicit
Sub TEST5()
    Dim ar, br, i&, dic As Object
   
    Set dic = CreateObject("Scripting.Dictionary")
   
    ar = Range("K3", Cells(Rows.Count, "L").End(xlUp)).Value
    For i = 2 To UBound(ar)
        If Not dic.exists(ar(i, 1)) Then
            dic(ar(i, 1)) = ar(i, 2)
        Else
            dic(ar(i, 1)) = dic(ar(i, 1)) & " " & ar(i, 2)
        End If
    Next i
    With Range("P3", Cells(Rows.Count, "P").End(xlUp))
        ar = .Value
        For i = 2 To UBound(ar)
            If dic.exists(ar(i, 1)) Then
                br = Split(dic(ar(i, 1)))
                .Cells(i, 2).Resize(UBound(br) + 1) = Application.Transpose(br)
            End If
        Next i
    End With
    Set dic = Nothing
    Beep
End Sub