[已解决]求大侠帮忙修改下代码

坏也是一种态度

Sub 需求2()   Dim r%, i%   Dim arr, brr()   Dim d As Object   Dim ws As Worksheet   Application.ScreenUpdating = False   Application.DisplayAlerts = False   Set d = CreateObject("scripting.dictionary")   With Worksheets("数据表")     r = .Cells(.Rows.Count, 1).End(xlUp).Row     arr = .Range("a2:k" & r)     For i = 1 To UBound(arr)       If arr(i, 10) <> "" And Not d.exists(arr(i, 10)) Then       d(arr(i, 10)) = Array(arr(i, 4), arr(i, 7), arr(i, 1), arr(i, 8), arr(i, 6))         ElseIf arr(i, 10) = "" Then         k = k + 1         ReDim Preserve brr(1 To 5, 1 To k)         brr(1, k) = arr(i, 4)         brr(2, k) = arr(i, 7)         brr(3, k) = arr(i, 1)         brr(4, k) = arr(i, 8)         brr(5, k) = arr(i, 6)       End If     Next   End With   With Worksheets("客户档案")     r = .Cells(.Rows.Count, 1).End(xlUp).Row + 1     .Cells(r, 1).Resize(d.Count, 5) = Application.Transpose(Application.Transpose(d.items))     r = .Cells(.Rows.Count, 1).End(xlUp).Row + 1     .Cells(r, 1).Resize(k, 5) = Application.Transpose(brr)     .Range("a1:ac" & r).Borders.LineStyle = xlContinuous   End With End Sub 大侠帮忙看修改下这个数据 这段代码刚开始运行正常可以执行 但后面不晓得咋了突然执行不了啦，数据格式什么的都没变动 其次对代码做下修改，具体需求见附件需求描述表中对需求2的描述

最佳答案

月排行榜 / 总排行榜

zjdh

2015-8-12 09:16

Sub 需求2()
  Dim r%, i%, arr, d As Object
   Set d = CreateObject("scripting.dictionary")
  With Worksheets("数据表")
    r = .Cells(.Rows.Count, 1).End(xlUp).Row
    arr = .Range("a2:k" & r)
    For i = 1 To UBound(arr)
      If arr(i, 10) = "" And arr(i, 11) <> "" Then
      d(arr(i, 1)) = Array(arr(i, 4), arr(i, 7), arr(i, 1), arr(i, 8), arr(i, 6))
      End If
    Next
  End With
  If d.Count = 0 Then MsgBox "不存在符合条件的数据！": Exit Sub
  With Worksheets("客户档案")
    r = .Cells(.Rows.Count, 1).End(xlUp).Row + 1
    .Cells(r, 1).Resize(d.Count, 5) = Application.Transpose(Application.Transpose(d.items))
    .Range("a1:ac" & r).Borders.LineStyle = xlContinuous
  End With
  MsgBox "数据提取完毕！"
End Sub

跳转到最佳答案楼层

zjdh

Sub 需求2()
  Dim r%, i%, arr, d As Object
   Set d = CreateObject("scripting.dictionary")
  With Worksheets("数据表")
    r = .Cells(.Rows.Count, 1).End(xlUp).Row
    arr = .Range("a2:k" & r)
    For i = 1 To UBound(arr)
      If arr(i, 10) = "" And arr(i, 11) <> "" Then
      d(arr(i, 1)) = Array(arr(i, 4), arr(i, 7), arr(i, 1), arr(i, 8), arr(i, 6))
      End If
    Next
  End With
  If d.Count = 0 Then MsgBox "不存在符合条件的数据！": Exit Sub
  With Worksheets("客户档案")
    r = .Cells(.Rows.Count, 1).End(xlUp).Row + 1
    .Cells(r, 1).Resize(d.Count, 5) = Application.Transpose(Application.Transpose(d.items))
    .Range("a1:ac" & r).Borders.LineStyle = xlContinuous
  End With
  MsgBox "数据提取完毕！"
End Sub

坏也是一种态度

zjdh 发表于 2015-8-12 09:16
Sub 需求2()
  Dim r%, i%, arr, d As Object
   Set d = CreateObject("scripting.dictionary")

大侠在么
麻烦你看下
我这个帖子http://www.excelpx.com/forum.php ... p;page=1#pid3941370
每个工作簿都有多个工作表这代码应该怎么改