请教各位大神

Jday1218

如何批量进行操作，

Jday1218

由于数据量大  如何进行批量操作生成，

dandan076

以我的想法，需要用代码

Jday1218

dandan076 发表于 2020-9-18 09:36
以我的想法，需要用代码

嗯嗯  请教具体怎么操作

dandan076

上台时间空的咋整呢？

Jday1218

dandan076 发表于 2020-9-18 09:47
上台时间空的咋整呢？

空的不用管了

dandan076

在这里，代码如下

1. Sub 转换()
   
2.     Dim irow As Long, i As Long, j As Long, arr1, arr2, k As Long
   
3.     Dim ws1 As Worksheet, ws2 As Worksheet
   
4.     Set ws1 = Sheets("Sheet1")
   
5.     Set ws2 = Sheets("Sheet2")
   
6.     k = 1
   
7.     ws1.Activate
   
8.     irow = Cells(Rows.Count, 5).End(xlUp).Row
   
9.     arr1 = ws1.Range("A2:P" & irow)
   
10.     ReDim arr2(1 To 1000000, 1 To 15)
    
11.     For i = 1 To irow - 1
    
12.         If arr1(i, 15) <> "" Then
    
13.             For j = 1 To 15
    
14.                 arr2(k, j) = arr1(i, j)
    
15.             Next
    
16.             If arr1(i, 16) <> "至今" Then
    
17.                 Do While arr2(k, 15) <= arr1(i, 16)
    
18.                     k = k + 1
    
19.                     For j = 1 To 14
    
20.                         arr2(k, j) = arr1(i, j)
    
21.                     Next
    
22.                     arr2(k, j) = arr2(k - 1, j) + 1
    
23.                 Loop
    
24.             Else
    
25.                 Do While arr2(k, 15) <= 2020
    
26.                     k = k + 1
    
27.                     For j = 1 To 14
    
28.                         arr2(k, j) = arr1(i, j)
    
29.                     Next
    
30.                     arr2(k, j) = arr2(k - 1, j) + 1
    
31.                 Loop
    
32.             End If
    
33.         End If
    
34.     Next
    
35.     ws2.Activate
    
36.     Range("A2").Resize(k, 15) = arr2
    
37. End Sub
    

复制代码

你要处理的表 表格名改成“Sheet1”，结果表 表格名改为“Sheet2”

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
这是代码，原表要改成“Sheet1”，结果表改成“Sheet2”
第一次发的说要审核，不知道跑哪里去了

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

dandan076

你帖子有问题，为什么我的回复都要审核？