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

yyj1254

shiruiqiang 发表于 2024-2-14 16:17
按照你帖子要求，把79改4

79是实际行数 4只是例子里面的行数

shiruiqiang

yyj1254 发表于 2024-2-14 21:32
79是实际行数 4只是例子里面的行数

smiletwo

字典比较方便，建议上传附件。

smiletwo

10楼已给出类似

3190496160

无非是数组+字典的问题而已，上传附件，很好解决，何必让别人在这里猜来猜去的呢

3190496160

Sub 分类汇总1()
Dim ar As Variant
Dim d As Object
Set d = CreateObject("scripting.dictionary")
With ActiveSheet
    r = .Cells(Rows.Count, 11).End(xlUp).Row
    If r < 4 Then MsgBox "数据源区域为空！": End
    ar = .Range("k3:l" & r)
    For i = 2 To UBound(ar)
        If ar(i, 1) <> "" Then
            If Not d.exists(ar(i, 1)) Then
                Set d(ar(i, 1)) = .Cells(i + 2, 11).Resize(1, 2)
            Else
                Set d(ar(i, 1)) = Union(d(ar(i, 1)), .Cells(i + 2, 11).Resize(1, 2))
            End If
        End If
    Next i
    rs = .Cells(Rows.Count, 16).End(xlUp).Row
    If rs >= 4 Then .Range("p4:q" & rs) = Empty
    x = d.keys
    m = 4
    For i = 0 To UBound(x)
        d.items()(i).Copy .Cells(m, 16)
        m = m + 4
    Next i
End With
MsgBox "ok!"
End Sub

3190496160

Sub 分类汇总2()
Dim ar As Variant
Dim d As Object
Set d = CreateObject("scripting.dictionary")
With ActiveSheet
    r = .Cells(Rows.Count, 11).End(xlUp).Row
    If r < 4 Then MsgBox "数据源区域为空！": End
    ar = .Range("k3:l" & r)
    For i = 2 To UBound(ar)
        If ar(i, 1) <> "" Then
            If Not d.exists(ar(i, 1)) Then
                d(ar(i, 1)) = .Cells(i + 2, 12)
            Else
                 d(ar(i, 1)) = d(ar(i, 1)) & "|" & .Cells(i + 2, 12)
            End If
        End If
    Next i
    rs = .Cells(Rows.Count, 16).End(xlUp).Row
    If rs >= 4 Then .Range("q4:q" & rs) = Empty
    ar = .Range("p3:q" & rs + 3)
    For i = 2 To UBound(ar)
        If ar(i, 1) <> "" Then
            If d.exists(ar(i, 1)) Then
                rr = Split(d(ar(i, 1)), "|")
                m = i - 1
                For s = 0 To UBound(rr)
                    m = m + 1
                    ar(m, 2) = rr(s)
                Next s
            End If
        End If
    Next i
    .Range("p3:q" & rs + 3) = ar
End With
MsgBox "ok!"
End Sub

3190496160

两种方案供选择
一是，清楚粘贴区域内所有数据，代码自动生成
二是，粘贴区域事先输入公司代码，代码按输入的公司代码所在的位置写入相应的数据
工作簿1.rar (18.77 KB, 下载次数: 9)

2024-2-15 11:15 上传

点击文件名下载附件

准提部林

在k列已排序, 且每家公司4行以內//
sub TTT()
dim xR as range, xA as range, xB as range,t$
set xB=[P4]
for each xR in range([K4], [K65536].end(3))
    if xR <> t then t = xR: set xA=xR(1, 2)
   if xR(2) <> t then range(xR, xA).copy xB: set xB=xB(5)
end sub

taller

yyj1254 发表于 2024-2-14 15:53
谢谢 但是这个看起来有点复杂 我研究下

1. Sub Demo()
   
2.     Dim i As Long, j As Long
   
3.     Dim arrData, rngData As Range
   
4.     Dim arrRes, iR As Long
   
5.     Dim LastRow As Long, iCode As String
   
6.     LastRow = Cells(Rows.Count, "A").End(xlUp).Row
   
7.     Set rngData = Range("A4:B" & LastRow)
   
8.     arrData = rngData.Value
   
9.     ReDim arrRes(1 To UBound(arrData) * 4, 1)
   
10.     iR = 0: iCode = ""
    
11.     For i = LBound(arrData) To UBound(arrData)
    
12.         iR = iR + 1
    
13.         If iCode <> arrData(i, 1) Then
    
14.             If iR > 1 Then
    
15.                 If (iR Mod 4) < 2 Then
    
16.                     iR = iR + 1 - (iR Mod 4)
    
17.                 Else
    
18.                     iR = iR + 5 - (iR Mod 4)
    
19.                 End If
    
20.             End If
    
21.             arrRes(iR, 0) = arrData(i, 1)
    
22.             iCode = arrData(i, 1)
    
23.         End If
    
24.         arrRes(iR, 1) = arrData(i, 2)
    
25.     Next i
    
26.     Range("P4:Q10000").ClearContents
    
27.     Range("P4").Resize(iR, 2) = arrRes
    
28. End Sub

复制代码