[已解决]通过VBA 改变数据格式

hadesqu

编程需要大量处理数据格式，希望大家帮忙看看附件，主要是想把sheet1和sheet2 中A列的数据改变格式成D列的

最佳答案

月排行榜 / 总排行榜

爱疯

2016-2-29 16:02

hadesqu 发表于 2016-2-29 13:48
求版主给个附件吧，我按你编码发现有问题，感谢~~~

测试时若发现有问题，你应上传测试的附件，并明确解释。
不该只丢一句话，毕竟其它朋友都是付出了时间和精力的。


我把输出放在F列，你先试试。





Dim d

'主程序
Sub main()
    Dim i, j, k, t
    For i = 1 To 2
        Sheets(i).Activate
        Call total

        k = d.keys: t = d.items
        For j = 0 To UBound(k)
            If t(j) > 1 Then
                Select Case i
                Case 1
                    k(j) = formatString1(k(j), t(j))
                Case 2
                    k(j) = formatString2(k(j), t(j))
                End Select
            End If
        Next j
        k = Application.Transpose(k)
        Range("f:f").ClearContents
        Range("f1").Resize(UBound(k), 1) = k
    Next i
End Sub

'求各项次数
Private Sub total()
    Dim A, i, x
    A = Range("a1").CurrentRegion
    Set d = CreateObject("scripting.dictionary")
    For i = 1 To UBound(A)
        x = VBA.InStr(A(i, 1), "[")
        x = IIf(x, x, Len(A(i, 1)))
        x = Left(A(i, 1), x)
        d(x) = d(x) + 1
    Next i
End Sub

'格式化表1的字符串
Function formatString1(x, y)
    Dim A, B
    A = VBA.Split(x, Chr(32))
    B = VBA.Split(A(1), "[")
    formatString1 = A(0) & " [0:" & y - 1 & "] " & B(0) & ","
End Function

'格式化表2的字符串
Function formatString2(x, y)
    Dim str$, num$
    str = Mid(x, 2, InStr(x, "[") - 2)
    num = "[0:" & y - 1 & "]"
    formatString2 = "." & num & str & " (" & num & str & "),"
End Function

test2.rar (12.15 KB, 下载次数: 6)

2016-2-29 16:00 上传

点击文件名下载附件

跳转到最佳答案楼层

爱疯

方便慢慢想{:04:}

爱疯

想到点思路了：
判断有无【，有就截取左边到【的子串到字典里计数，无直接添加到字典计数。

蓝桥玄霜

请见代码。

hadesqu

蓝桥玄霜 发表于 2016-2-29 12:09
请见代码。

求版主给个附件吧，我按你编码发现有问题，感谢~~~

hadesqu

爱疯 发表于 2016-2-29 12:04
想到点思路了：
判断有无【，有就截取左边到【的子串到字典里计数，无直接添加到字典计数。

爱疯大神帮忙想想吧，版主可能比较忙，可能没空~~~

爱疯

hadesqu 发表于 2016-2-29 13:48
求版主给个附件吧，我按你编码发现有问题，感谢~~~

测试时若发现有问题，你应上传测试的附件，并明确解释。
不该只丢一句话，毕竟其它朋友都是付出了时间和精力的。


我把输出放在F列，你先试试。





Dim d

'主程序
Sub main()
    Dim i, j, k, t
    For i = 1 To 2
        Sheets(i).Activate
        Call total

        k = d.keys: t = d.items
        For j = 0 To UBound(k)
            If t(j) > 1 Then
                Select Case i
                Case 1
                    k(j) = formatString1(k(j), t(j))
                Case 2
                    k(j) = formatString2(k(j), t(j))
                End Select
            End If
        Next j
        k = Application.Transpose(k)
        Range("f:f").ClearContents
        Range("f1").Resize(UBound(k), 1) = k
    Next i
End Sub

'求各项次数
Private Sub total()
    Dim A, i, x
    A = Range("a1").CurrentRegion
    Set d = CreateObject("scripting.dictionary")
    For i = 1 To UBound(A)
        x = VBA.InStr(A(i, 1), "[")
        x = IIf(x, x, Len(A(i, 1)))
        x = Left(A(i, 1), x)
        d(x) = d(x) + 1
    Next i
End Sub

'格式化表1的字符串
Function formatString1(x, y)
    Dim A, B
    A = VBA.Split(x, Chr(32))
    B = VBA.Split(A(1), "[")
    formatString1 = A(0) & " [0:" & y - 1 & "] " & B(0) & ","
End Function

'格式化表2的字符串
Function formatString2(x, y)
    Dim str$, num$
    str = Mid(x, 2, InStr(x, "[") - 2)
    num = "[0:" & y - 1 & "]"
    formatString2 = "." & num & str & " (" & num & str & "),"
End Function

test2.rar (12.15 KB, 下载次数: 6)

2016-2-29 16:00 上传

点击文件名下载附件

hadesqu

爱疯 发表于 2016-2-29 16:02
测试时若发现有问题，你应上传测试的附件，并明确解释。
不该只丢一句话，毕竟其它朋友都是付出了时间和 ...

是，是，我错啦，下次一定注意~~~

hadesqu

爱疯 发表于 2016-2-29 16:02
测试时若发现有问题，你应上传测试的附件，并明确解释。
不该只丢一句话，毕竟其它朋友都是付出了时间和 ...

感谢，就是这样，有些小问题，我自己修改就好，谢谢~~~{:29:}