[已解决]帮忙看看

qwh923820

要把单独的任务单号拆开，对应 生产日期。
用VBA则怎么实现，拆开后放在同一列，对应生产的日期。






求助.rar (5.78 KB, 下载次数: 3)

2015-12-24 20:50 上传

点击文件名下载附件 比如第一个拆成

2015-005	1	11月12日
2015-006	1	11月12日
2015-007	1	11月12日
2015-008	1	11月12日
2015-009	1	11月12日
2015-022	1	11月12日

最佳答案

月排行榜 / 总排行榜

爱疯

2015-12-24 23:19

Option Explicit


Dim Arr(1 To 10 ^ 4, 1 To 2), s

Sub test1()
    Dim A, i
    s = 0
    A = Range("a1").CurrentRegion
    For i = 2 To UBound(A)
        Call test2(A(i, 2), A(i, 4))
    Next i

    Range("h:i").ClearContents
    Range("i:I").NumberFormat = "m月d日"
    [h1].Resize(UBound(Arr), UBound(Arr, 2)) = Arr
End Sub

Sub test2(x, y)
    Dim A, B, id, i
    id = Left(x, 5)
    x = Mid(x, 6)
    A = VBA.Split(x, ",")
    If Len(x) > 3 And Mid(x, 4, 1) = "-" Then
        B = VBA.Split(A(0), "-")
        For i = B(0) To B(1)
            s = s + 1
            Arr(s, 1) = id & Format(i, "000")
            Arr(s, 2) = y
        Next i
    Else
        s = s + 1
        Arr(s, 1) = id & A(0)
        Arr(s, 2) = y
    End If

    For i = 1 To UBound(A)
        s = s + 1
        Arr(s, 1) = id & Format(A(i), "000")
        Arr(s, 2) = y
    Next i
End Sub

求助2.rar (10.23 KB, 下载次数: 5)

2015-12-24 23:19 上传

点击文件名下载附件

跳转到最佳答案楼层

橘子红

单号和生成日期是什么关系,看不到规律

qwh923820

橘子红 发表于 2015-12-24 20:54
单号和生成日期是什么关系,看不到规律

第一个  ，2015-005-09就是2015-005到2015-009共5格，加上2015-022共6个，后面 对应的日期都是在第一行，所以一样的

连号的都是XX-XX，
不连号的一般都是，隔开

单号2015-这个开头

qwh923820

我不知道思路对不对，有没有更好的办法。到现在还没有整出来。

我是这样做的，首先自动插入空白行
然后把每个都用“，”进行分行，变成单号

再将连续的用循环整成单个

爱疯

Option Explicit


Dim Arr(1 To 10 ^ 4, 1 To 2), s

Sub test1()
    Dim A, i
    s = 0
    A = Range("a1").CurrentRegion
    For i = 2 To UBound(A)
        Call test2(A(i, 2), A(i, 4))
    Next i

    Range("h:i").ClearContents
    Range("i:I").NumberFormat = "m月d日"
    [h1].Resize(UBound(Arr), UBound(Arr, 2)) = Arr
End Sub

Sub test2(x, y)
    Dim A, B, id, i
    id = Left(x, 5)
    x = Mid(x, 6)
    A = VBA.Split(x, ",")
    If Len(x) > 3 And Mid(x, 4, 1) = "-" Then
        B = VBA.Split(A(0), "-")
        For i = B(0) To B(1)
            s = s + 1
            Arr(s, 1) = id & Format(i, "000")
            Arr(s, 2) = y
        Next i
    Else
        s = s + 1
        Arr(s, 1) = id & A(0)
        Arr(s, 2) = y
    End If

    For i = 1 To UBound(A)
        s = s + 1
        Arr(s, 1) = id & Format(A(i), "000")
        Arr(s, 2) = y
    Next i
End Sub

求助2.rar (10.23 KB, 下载次数: 5)

2015-12-24 23:19 上传

点击文件名下载附件

qwh923820

好强大的版主

qwh923820

谢谢斑竹的帮助，这是最后我自己整理的，这样即使中间有循环了，而且如果数据循环有错还能报错。即使工单输入的时候有错，出现字母，程序也能停下

Option Explicit

Dim Arr(1 To 1000, 1 To 2), s



Sub chaikai1()
'
' 拆
'

'


Dim A, i, id2, id3, zhi
    s = 0
    A = Range("a1").CurrentRegion
    For i = 2 To UBound(A)
        zhi = Cells(i, 1)
        
            id2 = Mid(zhi, 9, 2)
            id3 = Right(zhi, 2)
            If CInt(id2) > CInt(id3) Then
                Cells(i, 5).Value = "有错"
            End If
            
        
        
        Call chaikai2(A(i, 1), A(i, 2))
   

    [c1].Resize(UBound(Arr), UBound(Arr, 2)) = Arr
    Next i





End Sub

Sub chaikai2(x, y)
'
' 拆
'

'

Dim A, B, id, j, i, AE, x1, x2, cf1, cf2, y1, y2

    id = Left(x, 8)

               
    x = Mid(x, 9)
    A = VBA.Split(x, ",")
   
   
    For j = 0 To UBound(A)
   
        If InStr(A(j), "-") > 0 Then
            AE = VBA.Split(A(j), "-")
            x1 = CStr(AE(0))
            x2 = CStr(AE(1))
            cf1 = Right(x1, 2)
            cf2 = Right(x2, 2)
            y1 = CInt(cf1)
            y2 = CInt(cf2)
            
                For i = y1 To y2
                s = s + 1
                Arr(s, 1) = id & Format(i, "00")
                Arr(s, 2) = y
                Next i
        Else
                s = s + 1
               
                Arr(s, 1) = id & Format(A(j), "00")
                Arr(s, 2) = y
        End If
        
    Next j



End Sub

qwh923820

又加个
Erase Arr()

这样就更没问题了