Excel精英培训网

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

[已解决]请教大家帮忙实现个功能

[复制链接]
发表于 2013-3-8 21:14 | 显示全部楼层 |阅读模式
本帖最后由 Pluto06 于 2013-3-8 23:32 编辑

大家好, 由于工作需要. 请教个东西:
我想把 下面 左边形式的东西, 点一下 convert按钮, 转变成 右边的形式. 也就是说, 一行只保留一个cell, 然后cell对应的内容表示为 例如 0&2&4, 而非0&0&0&0&0&0&2&2&2&2&2&2&4&4&4&4&4&4 (数字和&之间没有空格)
不知道该怎么操作呢? (请注意, 每个cell-A, cell-B以此类推, 对应的一个数字都是重复了8遍)

Testing1.rar (13.81 KB, 下载次数: 1)
发表于 2013-3-8 22:16 | 显示全部楼层    本楼为最佳答案   
Testing.rar (16.17 KB, 下载次数: 11)
回复

使用道具 举报

 楼主| 发表于 2013-3-8 22:22 | 显示全部楼层
本帖最后由 Pluto06 于 2013-3-8 22:25 编辑
hwc2ycy 发表于 2013-3-8 22:16

好厉害, 谢谢你啦.

对了, 能不能帮我在输出的数字之间加入符号"&", 也就是 0&2&4 这种形式呢?

如果 "&" 没办法或是很难实现的话, 用 分号 ";" 也可以.

另外, 请教下, 您这个VB实现中, 有没有什么特别限制? 呵呵

劳烦啦
回复

使用道具 举报

发表于 2013-3-8 22:38 | 显示全部楼层
  1. Private Sub CommandButton1_Click()
  2.     Dim dic As Object
  3.     Dim arr, KeyItem, KeyValue As String
  4.    
  5.     Dim lLastrow As Long

  6.     lLastrow = Cells(Rows.Count, 1).End(xlUp).Row
  7.     If lLastrow = 1 Then Exit Sub
  8.     arr = Range("a2:b" & lLastrow)

  9.     Set dic = CreateObject("scripting.dictionary")

  10.     For i = LBound(arr) To UBound(arr)
  11.         dic(arr(i, 1)) = dic(arr(i, 1)) & arr(i, 2) & " & "
  12.     Next
  13.    
  14.     For Each KeyItem In dic.keys
  15.         KeyValue = dic(KeyItem)
  16.         dic(KeyItem) = Left(KeyValue, Len(KeyValue) - 3)
  17.     Next
  18.    
  19.     lLastrow = Cells(Rows.Count, 4).End(xlUp).Row

  20.     Application.ScreenUpdating = False

  21.     If lLastrow > 1 Then Range("d2:e" & lLastrow) = ""

  22.     If dic.Count > 0 Then
  23.         Range("d2").Resize(dic.Count) = WorksheetFunction.Transpose(dic.keys)
  24.         Range("e2").Resize(dic.Count) = WorksheetFunction.Transpose(dic.items)
  25.         MsgBox "OK"
  26.     End If

  27.     Set dic = Nothing
  28.     Application.ScreenUpdating = True

  29. End Sub
复制代码
回复

使用道具 举报

 楼主| 发表于 2013-3-8 22:41 | 显示全部楼层
hwc2ycy 发表于 2013-3-8 22:38

不好意思哈.
又得麻烦您了.
能否把数字和&之间的空格去掉呢
希望是: 0&2&4
而非: 0 & 2 & 4

谢谢
回复

使用道具 举报

发表于 2013-3-8 22:45 | 显示全部楼层
  1.    dic(arr(i, 1)) = dic(arr(i, 1)) & arr(i, 2) & " & "
复制代码
改成
  1.    dic(arr(i, 1)) = dic(arr(i, 1)) & arr(i, 2) & "&"
复制代码
  1.         dic(KeyItem) = Left(KeyValue, Len(KeyValue) - 3)
复制代码
改成
  1.         dic(KeyItem) = Left(KeyValue, Len(KeyValue) - 1)
复制代码
回复

使用道具 举报

发表于 2013-3-8 22:51 | 显示全部楼层
  1. Private Sub CommandButton1_Click()
  2.     Dim dic As Object
  3.     Dim arr, KeyItem, KeyValue As String
  4.    
  5.     Dim lLastrow As Long

  6.     lLastrow = Cells(Rows.Count, 1).End(xlUp).Row
  7.     If lLastrow = 1 Then Exit Sub
  8.     arr = Range("a2:b" & lLastrow)

  9.     Set dic = CreateObject("scripting.dictionary")

  10.     For i = LBound(arr) To UBound(arr)
  11.         dic(arr(i, 1)) = dic(arr(i, 1)) & arr(i, 2) & "&"
  12.     Next
  13.    
  14.     For Each KeyItem In dic.keys
  15.         KeyValue = dic(KeyItem)
  16.         dic(KeyItem) = Left(KeyValue, Len(KeyValue) - 1)
  17.     Next
  18.    
  19.     lLastrow = Cells(Rows.Count, 4).End(xlUp).Row

  20.     Application.ScreenUpdating = False

  21.     If lLastrow > 1 Then Range("d2:e" & lLastrow) = ""

  22.     If dic.Count > 0 Then
  23.         Range("d2").Resize(dic.Count) = WorksheetFunction.Transpose(dic.keys)
  24.         Range("e2").Resize(dic.Count) = WorksheetFunction.Transpose(dic.items)
  25.         MsgBox "OK"
  26.     End If

  27.     Set dic = Nothing
  28.     Application.ScreenUpdating = True

  29. End Sub
复制代码
回复

使用道具 举报

 楼主| 发表于 2013-3-8 23:02 | 显示全部楼层
本帖最后由 Pluto06 于 2013-3-8 23:03 编辑
hwc2ycy 发表于 2013-3-8 22:51

非常感谢.

还有最后一个进阶的:
和之前的基本相同, 但是每个cell对应的只会重复8遍 (确认只会是8遍), 能否输出的东西还和原来一样, 是0&2&4, 而不是0&0&0&0&0&0&2&2&2&2&2&2&4&4&4&4&4&4

(不好意思, 截图里面重复6遍, 弄错了, 应该是8遍)
捕获.JPG
回复

使用道具 举报

 楼主| 发表于 2013-3-8 23:29 | 显示全部楼层
有点急需. 劳烦啦
回复

使用道具 举报

 楼主| 发表于 2013-3-9 10:16 | 显示全部楼层
hwc2ycy 发表于 2013-3-8 22:51

专家. 麻烦你再帮一次吧.
在上面的基础上进阶一点..
实现:
和之前的基本相同, 但是每个cell对应的只会重复8遍 (确认只会是8遍), 能否输出的东西还和原来一样, 是0&2&4, 而不是0&0&0&0&0&0&2&2&2&2&2&2&4&4&4&4&4&4

(不好意思, 截图里面重复6遍, 弄错了, 应该是8遍)



回复

使用道具 举报

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

本版积分规则

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

GMT+8, 2024-3-29 19:52 , Processed in 0.323153 second(s), 10 queries , Gzip On, Yac On.

Powered by Discuz! X3.4

Copyright © 2001-2020, Tencent Cloud.

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