Excel精英培训网

 找回密码
 注册
数据透视表40+个常用小技巧,让你一次学会!
查看: 1429|回复: 7

[已解决]VBA求助

[复制链接]
发表于 2013-5-1 05:25 | 显示全部楼层 |阅读模式
求数.rar (393.24 KB, 下载次数: 8)
excel精英培训的微信平台,每天都会发送excel学习教程和资料。扫一扫明天就可以收到新教程
发表于 2013-5-1 06:41 | 显示全部楼层
回复

使用道具 举报

发表于 2013-5-1 06:48 | 显示全部楼层
回复

使用道具 举报

发表于 2013-5-1 06:53 | 显示全部楼层
  1. Sub test()
  2.     Dim lCol&
  3.     Dim lRept&
  4.     Dim result, arr
  5.     Dim lLastRow&
  6.     Columns(1).ClearContents
  7.     lLastRow = Cells(Rows.Count, 1).End(xlUp).Row
  8.     For lCol = 9 To 12
  9.         arr = Range(Cells(3, lCol), Cells(10000, lCol))
  10.         If VBA.IsNumeric(Cells(1, lCol)) And Len(Cells(1, lCol)) > 0 Then
  11.             If Cells(1, lCol) < 9 Or Cells(1, lCol) > 32 Then
  12.                 result = CheckRept(arr, Cells(1, lCol))
  13.                 If IsArray(result) Then
  14.                       Cells(lLastRow, 1).Resize(UBound(result)) = WorksheetFunction.Transpose(result)
  15.                     lLastRow = Cells(Rows.Count, 1).End(xlUp).Row + 1
  16.                     'lLastRow = lLastRow + UBound(result)
  17.                 End If
  18.             End If
  19.         End If
  20.     Next
  21. End Sub

  22. Function CheckRept(arr, lCondition As Long)
  23.     If Not IsArray(arr) Then CheckRept = False: Exit Function
  24.     If lCondition <= 0 Then CheckRept = False: Exit Function
  25.     Dim lCount&
  26.     Dim result()

  27.     Dim dic As Object

  28.     Set dic = CreateObject("scripting.dictionary")
  29.     Dim i As Long
  30.     Dim keys
  31.     ReDim result(1 To 1)
  32.     For i = LBound(arr) To UBound(arr)
  33.         dic(arr(i, 1)) = dic(arr(i, 1)) + 1
  34.     Next
  35.     For Each keys In dic.keys
  36.         If dic(keys) = lCondition Then
  37.             lCount = lCount + 1
  38.             ReDim Preserve result(1 To lCount)
  39.             result(lCount) = "'" & keys
  40.         End If
  41.     Next
  42.     If lCount > 1 Then
  43.         CheckRept = result
  44.     Else
  45.         CheckRept = False
  46.     End If
  47. End Function
复制代码
回复

使用道具 举报

发表于 2013-5-1 06:55 | 显示全部楼层
改下
  1. Sub test()
  2.     Dim lCol&
  3.     Dim lRept&
  4.     Dim result, arr
  5.     Dim lLastRow&
  6.     Columns(1).ClearContents
  7.     lLastRow = Cells(Rows.Count, 1).End(xlUp).Row
  8.     Application.ScreenUpdating = False
  9.     For lCol = 9 To 12
  10.         If VBA.IsNumeric(Cells(1, lCol)) And Len(Cells(1, lCol)) > 0 Then
  11.             If Cells(1, lCol) < 9 Or Cells(1, lCol) > 32 Then
  12.                 arr = Range(Cells(3, lCol), Cells(10000, lCol))
  13.                 result = CheckRept(arr, Cells(1, lCol))
  14.                 If IsArray(result) Then
  15.                     Cells(lLastRow, 1).Resize(UBound(result)) = WorksheetFunction.Transpose(result)
  16.                     lLastRow = Cells(Rows.Count, 1).End(xlUp).Row + 1
  17.                     'lLastRow = lLastRow + UBound(result)
  18.                 End If
  19.             End If
  20.         End If
  21.     Next
  22.     Application.ScreenUpdating = True
  23.     MsgBox "提取完成"
  24. End Sub

  25. Function CheckRept(arr, lCondition As Long)
  26.     If Not IsArray(arr) Then CheckRept = False: Exit Function
  27.     If lCondition <= 0 Then CheckRept = False: Exit Function
  28.     Dim lCount&
  29.     Dim result()

  30.     Dim dic As Object

  31.     Set dic = CreateObject("scripting.dictionary")
  32.     Dim i As Long
  33.     Dim keys
  34.     ReDim result(1 To 1)
  35.     For i = LBound(arr) To UBound(arr)
  36.         dic(arr(i, 1)) = dic(arr(i, 1)) + 1
  37.     Next
  38.     For Each keys In dic.keys
  39.         If dic(keys) = lCondition Then
  40.             lCount = lCount + 1
  41.             ReDim Preserve result(1 To lCount)
  42.             result(lCount) = "'" & keys
  43.         End If
  44.     Next
  45.     If lCount > 1 Then
  46.         CheckRept = result
  47.     Else
  48.         CheckRept = False
  49.     End If
  50. End Function
复制代码
回复

使用道具 举报

 楼主| 发表于 2013-5-1 09:48 | 显示全部楼层
hwc2ycy 发表于 2013-5-1 06:55
改下

输岀在a列的结果不要定死从第一格开始,因为前面用时也放了些数,改成有数的下一格开始更方便
回复

使用道具 举报

发表于 2013-5-1 10:03 | 显示全部楼层    本楼为最佳答案   
  1. Sub test()
  2.     Dim lCol&
  3.     Dim lRept&
  4.     Dim result, arr
  5.     Dim lLastRow&
  6.     'Columns(1).ClearContents
  7.    'lLastRow = Cells(Rows.Count, 1).End(xlUp).Row
  8.     Application.ScreenUpdating = False
  9.     For lCol = 9 To 12
  10.         If VBA.IsNumeric(Cells(1, lCol)) And Len(Cells(1, lCol)) > 0 Then
  11.             If Cells(1, lCol) < 9 Or Cells(1, lCol) > 32 Then
  12.                 arr = Range(Cells(3, lCol), Cells(10000, lCol))
  13.                 result = CheckRept(arr, Cells(1, lCol))
  14.                 If IsArray(result) Then
  15.                     lLastRow = Cells(Rows.Count, 1).End(xlUp).Row + 1
  16.                     Cells(lLastRow, 1).Resize(UBound(result)) = WorksheetFunction.Transpose(result)
  17.                     'lLastRow = lLastRow + UBound(result)
  18.                 End If
  19.             End If
  20.         End If
  21.     Next
  22.     Application.ScreenUpdating = True
  23.     MsgBox "提取完成"
  24. End Sub

  25. Function CheckRept(arr, lCondition As Long)
  26.     If Not IsArray(arr) Then CheckRept = False: Exit Function
  27.     If lCondition <= 0 Then CheckRept = False: Exit Function
  28.     Dim lCount&
  29.     Dim result()

  30.     Dim dic As Object

  31.     Set dic = CreateObject("scripting.dictionary")
  32.     Dim i As Long
  33.     Dim keys
  34.     ReDim result(1 To 1)
  35.     For i = LBound(arr) To UBound(arr)
  36.         dic(arr(i, 1)) = dic(arr(i, 1)) + 1
  37.     Next
  38.     For Each keys In dic.keys
  39.         If dic(keys) = lCondition Then
  40.             lCount = lCount + 1
  41.             ReDim Preserve result(1 To lCount)
  42.             result(lCount) = "'" & keys
  43.         End If
  44.     Next
  45.     If lCount > 1 Then
  46.         CheckRept = result
  47.     Else
  48.         CheckRept = False
  49.     End If
  50. End Function
复制代码
回复

使用道具 举报

发表于 2013-5-1 10:35 | 显示全部楼层
这字母、字符堆的………………
回复

使用道具 举报

您需要登录后才可以回帖 登录 | 注册

本版积分规则

小黑屋|手机版|Archiver|Excel精英培训 ( 豫ICP备11015029号 )

GMT+8, 2024-3-28 23:34 , Processed in 0.621263 second(s), 10 queries , Gzip On, Yac On.

Powered by Discuz! X3.4

Copyright © 2001-2020, Tencent Cloud.

快速回复 返回顶部 返回列表