Excel精英培训网

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

[已解决]自字义函数写成sub过程

[复制链接]
发表于 2015-6-16 20:58 | 显示全部楼层 |阅读模式
自字义函数怎么写成sub过程?
最佳答案
2015-6-17 09:44
  1. Sub 用逗号合并单元()
  2.     Dim rng1 As Range, rng2 As Range
  3.     Set rng1 = Application.InputBox("请选择源区域", "温馨提示", , , , , , 8)
  4.     Set rng2 = Application.InputBox("请选择存放区域", "温馨提示", , , , , , 8)
  5.     If rng1 Is Nothing Then MsgBox "请选择源区域": Exit Sub
  6.     If rng2 Is Nothing Then MsgBox "请选择存放区域": Exit Sub
  7.     rng2.Cells(1, 1).Resize(rng1.Rows.Count, 1) = ToJoin(rng1)
  8. End Sub
复制代码

自字义函数写成sub过程.rar

10.23 KB, 下载次数: 9

excel精英培训的微信平台,每天都会发送excel学习教程和资料。扫一扫明天就可以收到新教程
发表于 2015-6-17 09:44 | 显示全部楼层    本楼为最佳答案   
  1. Sub 用逗号合并单元()
  2.     Dim rng1 As Range, rng2 As Range
  3.     Set rng1 = Application.InputBox("请选择源区域", "温馨提示", , , , , , 8)
  4.     Set rng2 = Application.InputBox("请选择存放区域", "温馨提示", , , , , , 8)
  5.     If rng1 Is Nothing Then MsgBox "请选择源区域": Exit Sub
  6.     If rng2 Is Nothing Then MsgBox "请选择存放区域": Exit Sub
  7.     rng2.Cells(1, 1).Resize(rng1.Rows.Count, 1) = ToJoin(rng1)
  8. End Sub
复制代码

自字义函数写成sub过程.rar

10.62 KB, 下载次数: 5

回复

使用道具 举报

 楼主| 发表于 2015-6-17 20:30 | 显示全部楼层
grf1973 发表于 2015-6-17 09:44

对于同行中有重复的先去掉重复再 JOIN,左边效果。

去重复后Join.rar

10.42 KB, 下载次数: 4

评分

参与人数 1 +3 收起 理由
liziyuliziyu7 + 3

查看全部评分

回复

使用道具 举报

发表于 2015-6-18 09:44 | 显示全部楼层
function加个去重的判断。
  1. Function ToJoin(Rng)
  2.     Dim arr, brr$(), i&, j&, ss$
  3.     arr = Rng
  4.     ReDim brr(1 To UBound(arr), 1 To 1)
  5.     For i = 1 To UBound(arr)
  6.         ss = ","
  7.         For j = 1 To UBound(arr, 2)
  8.             If Not IsError(arr(i, j)) Then
  9.                 If Len(arr(i, j)) > 0 And InStr(ss, "," & arr(i, j) & ",") = 0 Then ss = ss & arr(i, j) & ","
  10.             End If
  11.         Next
  12.         brr(i, 1) = Mid(ss, 2, Len(ss) - 2)       '去掉首尾逗号
  13.     Next
  14.     If i = 2 Then
  15.         ToJoin = brr(i, 1)
  16.     Else
  17.         ToJoin = brr '   数组形式,引用所有区域后三键结束!
  18.     End If
  19. End Function
复制代码

评分

参与人数 1 +9 收起 理由
张雄友 + 9 很给力!

查看全部评分

回复

使用道具 举报

发表于 2015-6-18 16:50 | 显示全部楼层
张雄友我佩服你,牛人!!!!!!!  
回复

使用道具 举报

 楼主| 发表于 2015-6-18 18:51 | 显示全部楼层
grf1973 发表于 2015-6-18 09:44
function加个去重的判断。


选择整列时没有数据输出。
Sub 去重复后用逗号合并单元() '选择整列时没有数据输出。  
  On Error Resume Next
    Dim rng1 As Range, rng2 As Range
    Set rng1 = Application.InputBox("请选择源区域", "温馨提示", , , , , , 8) '选择F:K列,试试。   
    Set rng2 = Application.InputBox("请选择存放区域", "温馨提示", , , , , , 8)
    If rng1 Is Nothing Then MsgBox "请选择源区域": Exit Sub
    If rng2 Is Nothing Then MsgBox "请选择存放区域": Exit Sub
    rng2.Cells(1, 1).Resize(rng1.Rows.Count, 1) = ToJoin(rng1)
End Sub

Function ToJoin(Rng)
    Dim arr, brr$(), i&, j&, ss$
    arr = Rng
    ReDim brr(1 To UBound(arr), 1 To 1)
    For i = 1 To UBound(arr)
        ss = ","
        For j = 1 To UBound(arr, 2)
            If Not IsError(arr(i, j)) Then
                If Len(arr(i, j)) > 0 And InStr(ss, "," & arr(i, j) & ",") = 0 Then ss = ss & arr(i, j) & ","
            End If
        Next
        brr(i, 1) = Mid(ss, 2, Len(ss) - 2)       '去掉首尾逗号
    Next
    If i = 2 Then
        ToJoin = brr(i, 1)
    Else
        ToJoin = brr '   数组形式,引用所有区域后三键结束!
    End If
End Function

去重复后Join-2.rar

9.97 KB, 下载次数: 4

回复

使用道具 举报

发表于 2015-6-19 09:54 | 显示全部楼层
问题出在全空的情况,ss长度小于2。小改一下
Function ToJoin(Rng)
    Dim arr, brr$(), i&, j&, ss$
    arr = Rng
    ReDim brr(1 To UBound(arr), 1 To 1)
    For i = 1 To UBound(arr)
        ss = ","
        For j = 1 To UBound(arr, 2)
            If Not IsError(arr(i, j)) Then
                If Len(arr(i, j)) > 0 And InStr(ss, "," & arr(i, j) & ",") = 0 Then ss = ss & arr(i, j) & ","
            End If
        Next
       If Len(ss) > 2 Then brr(i, 1) = Mid(ss, 2, Len(ss) - 2)     '去掉首尾逗号
    Next
    If i = 2 Then
        ToJoin = brr(i, 1)
    Else
        ToJoin = brr '   数组形式,引用所有区域后三键结束!
    End If
End Function

评分

参与人数 1 +9 收起 理由
张雄友 + 9 很给力!

查看全部评分

回复

使用道具 举报

 楼主| 发表于 2015-6-19 19:41 | 显示全部楼层
grf1973 发表于 2015-6-19 09:54
问题出在全空的情况,ss长度小于2。小改一下
Function ToJoin(Rng)
    Dim arr, brr$(), i&, j&, ss$

If i = 2 Then
        ToJoin = brr(i, 1)
    Else
        ToJoin = brr '   数组形式,引用所有区域后三键结束!
    End If
End Function


红色代码是不对的,当源区域只选择一行时,没有数据输出。改成:If i = 1 Then  测试通过。
回复

使用道具 举报

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

本版积分规则

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

GMT+8, 2024-3-29 18:12 , Processed in 1.006679 second(s), 14 queries , Gzip On, Yac On.

Powered by Discuz! X3.4

Copyright © 2001-2020, Tencent Cloud.

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