请教各位大神

dandan076

Sub 转换()
    Dim irow As Long, i As Long, j As Long, arr1, arr2, k As Long
    Dim ws1 As Worksheet, ws2 As Worksheet
    Set ws1 = Sheets("Sheet1")
    Set ws2 = Sheets("Sheet2")
    k = 1
    ws1.Activate
    irow = Cells(Rows.Count, 5).End(xlUp).Row
    arr1 = ws1.Range("A2:P" & irow)
    ReDim arr2(1 To 1000000, 1 To 15)
    For i = 1 To irow - 1
        If arr1(i, 15) <> "" Then
            For j = 1 To 15
                arr2(k, j) = arr1(i, j)
            Next
            If arr1(i, 16) <> "至今" Then
                Do While arr2(k, 15) <= arr1(i, 16)
                    k = k + 1
                    For j = 1 To 14
                        arr2(k, j) = arr1(i, j)
                    Next
                    arr2(k, j) = arr2(k - 1, j) + 1
                Loop
            Else
                Do While arr2(k, 15) <= 2020
                    k = k + 1
                    For j = 1 To 14
                        arr2(k, j) = arr1(i, j)
                    Next
                    arr2(k, j) = arr2(k - 1, j) + 1
                Loop
            End If
        End If
    Next
    ws2.Activate
    Range("A2").Resize(k, 15) = arr2
End Sub

Jday1218

dandan076 发表于 2020-9-18 10:19
你帖子有问题，为什么我的回复都要审核？

好吧  可能涉及敏感词了

dandan076

Sub 转换()
    Dim irow As Long, i As Long, j As Long, arr1, arr2, k As Long
    Dim ws1 As Worksheet, ws2 As Worksheet
    Set ws1 = Sheets("Sheet1")
    Set ws2 = Sheets("Sheet2")
'    k = 1
    ws1.Activate
    irow = Cells(Rows.Count, 5).End(xlUp).Row
    arr1 = ws1.Range("A2:P" & irow)
    ReDim arr2(1 To 1000000, 1 To 15)
    For i = 1 To irow - 1
        If arr1(i, 15) <> "" Then
            k = k + 1
            For j = 1 To 15
                arr2(k, j) = arr1(i, j)
            Next
            If arr1(i, 16) <> "至今" Then
                Do While arr2(k, 15) < arr1(i, 16)
                    k = k + 1
                    For j = 1 To 14
                        arr2(k, j) = arr1(i, j)
                    Next
                    arr2(k, j) = arr2(k - 1, j) + 1
                Loop
            Else
                Do While arr2(k, 15) < 2020
                    k = k + 1
                    For j = 1 To 14
                        arr2(k, j) = arr1(i, j)
                    Next
                    arr2(k, j) = arr2(k - 1, j) + 1
                Loop
            End If
        End If
    Next
    ws2.Activate
    Range("A2").Resize(k, 15) = arr2
End Sub
代码稍微有点问题，修改了一下

dandan076

发现有点问题，同一个人在同一个年份两个职位的

Jday1218

dandan076 发表于 2020-9-18 10:39
发现有点问题，同一个人在同一个年份两个职位的

嗯嗯  不过你这个已经很厉害了  这个数据格式有问题，