[已解决]VBA如何设置单元格部分内容一致的条件

abedwqr2144

如附件资料，
手动操作的话
先用VBA取得文件夹内所有图片的名字（附件“文件名”sheet）
下划线“_”前面番号一致的选择复制
粘贴到“结果”sheet相应的图片名单元格内
由于番号没有规律，所以不知道如何提取下划线“_”前面内容一致的部分
求高手帮忙

最佳答案

月排行榜 / 总排行榜

xdd_sky

2013-5-27 14:22

看看是否符合你的要求。。。

跳转到最佳答案楼层

abedwqr2144

选择性粘贴→转置
可以录个宏，就是这个条件太头大了~
百度里面搜半天了也没找到解决办法

1032446692

Option Explicit
Sub test()
    Dim a, i, k, st, arra, arrb, diction, dictiona
    Set diction = CreateObject("scripting.dictionary")
    Set dictiona = CreateObject("scripting.dictionary")
    Sheets(1).Select
    a = Cells(60000, 1).End(xlUp).Row
    arra = Cells(1, 1).Resize(a)
    ReDim arrb(1 To a, 1 To a + 1)
    For i = 1 To a
        st = Left(arra(i, 1), InStr(1, arra(i, 1), "_") - 1)
        If diction.exists(st) Then
            dictiona(st) = dictiona(st) + 1
            arrb(diction(st), dictiona(st)) = arra(i, 1)
        Else
            k = k + 1
            diction(st) = k
            dictiona(st) = 2
            arrb(k, 1) = st
            arrb(k, 2) = arra(i, 1)
        End If
    Next i
    Sheets(2).Cells(2, 1).Resize(a, a + 1) = arrb
End Sub

abedwqr2144

厉害~！
可是为什么_1.jpg的都不见了呢？只有最后的一个还在

xdd_sky

看看是否符合你的要求。。。

abedwqr2144

xdd_sky 发表于 2013-5-27 14:22
看看是否符合你的要求。。。

看不到编码……不过成功了！
管理员写的那个我再研究研究
学海无涯啊~~哈哈！！

xdd_sky

编码在sheet2还是sheet1里面   你可以找找  

abedwqr2144

xdd_sky 发表于 2013-5-27 14:45
编码在sheet2还是sheet1里面   你可以找找

恩！谢啦！