vba中的插入问题

tcn541

因为文件太大上传不了，简单做了处理，请各位有空帮帮忙
或者你有别的办法也可以

liyf3

你的要求太复杂了,搞不定

windimi007

说句实话，不太确定是不是楼主想要的结果，楼主测试一下吧！{:3912:}
P.S. 运行速度很慢……{:712:}

1. Sub test()    Dim d As Object
   
2.     Dim arr, brr, crr(1 To 100000, 1 To 3)
   
3.     Dim i As Long, j As Long
   
4.     Dim sr As String
   
5.     Dim x
   
6.     Dim dj As Double
   
7.     Set d = CreateObject("scripting.dictionary")
   
8.     With Sheets("整理")
   
9.         arr = .Cells(1, 1).CurrentRegion
   
10.         brr = .Cells(1, "K").CurrentRegion
    
11.         For i = 2 To UBound(arr)
    
12.             If Not d.exists(arr(i, 1)) Then d.Add arr(i, 1), Array(arr(i, 2), arr(i, 7), 0)
    
13.         Next i
    
14.         For i = 2 To UBound(brr)
    
15.             sr = Left(brr(i, 1), 10)
    
16.             If d.exists(sr) Then d(sr) = Array(d(sr)(0), d(sr)(1), d(sr)(2) + 1)
    
17.         Next i
    
18.         For Each x In d.keys
    
19.             dj = d(x)(1)
    
20.             j = j + 1
    
21.             crr(j, 1) = x
    
22.             crr(j, 2) = d(x)(0)
    
23.             crr(j, 3) = dj
    
24.             For k = 1 To d(x)(2)
    
25.                 j = j + 1
    
26.                 crr(j, 3) = dj
    
27.             Next k
    
28.         Next x
    
29.     End With
    
30.     With Sheets("要求")
    
31.         .Cells.Clear
    
32.         .Cells(1, 1).Resize(j, 3) = crr
    
33.     End With
    
34. End Sub

复制代码

zjcat35

1. Sub a()
   
2.     Dim arr, i%, brr(), j%, t
   
3.     Application.ScreenUpdating = False
   
4.     i = Cells(Rows.Count, 1).End(3).Row
   
5.     ReDim brr(1 To i - 1)
   
6.     arr = Range("a2").Resize(i - 1, 7)
   
7.     For j = 1 To i - 1
   
8.         brr(j) = Application.CountIf(Range("k:k"), arr(j, 1) & "*")
   
9.     Next j
   
10.     For j = i To 2 Step -1
    
11.         If brr(j - 1) > 1 Then
    
12.             Cells(j + 1, 1).Resize(brr(j - 1) - 1, 7).Insert shift:=xlDown
    
13.             Cells(j + 1, 7).Resize(brr(j - 1) - 1) = arr(j - 1, 7)
    
14.         End If
    
15.     Next j
    
16.     Application.ScreenUpdating = True
    
17. End Sub

复制代码

jxncfxsf

用数组做的，速度还是太慢，不知道还有什么更好的办法吗？
Sub a()
    Dim arr, ar, brr, crr(), t
    Dim i, j As Long
    t = Timer
    i = Cells(Rows.Count, 1).End(3).Row
    arr = Range("a2:G" & i)
    ar = Application.Index(arr, 0, 1)
    For j = 1 To UBound(ar)
    ar(j, 1) = ar(j, 1) & "*"
    Next j

brr = Application.CountIf(Range("k:k"), ar)

ReDim crr(1 To UBound(arr) + Application.Sum(brr), 1 To 8)
j = 1
For i = 1 To UBound(ar)
  crr(j, 1) = arr(i, 1)
  crr(j, 2) = arr(i, 2)
  crr(j, 3) = arr(i, 3)
  crr(j, 4) = arr(i, 4)
  crr(j, 5) = arr(i, 5)
  crr(j, 6) = arr(i, 6)
  crr(j, 7) = arr(i, 7)
  j = j + 1 + brr(i, 1)
  Next i
  For i = 1 To UBound(crr)
  If crr(i, 7) = "" Then crr(i, 7) = crr(i - 1, 7)
  Next i
  Range("a2:i" & Rows.Count).Clear
Range("a2").Resize(UBound(crr), 8) = crr
MsgBox Timer - t
End Sub