[已解决]请帮忙修改下代码

KDZ

      各位大侠：一个老师帮忙搞了一个代码【代码在汇总表内】，可以运行，只是有个小问题：运行代码后实战表的有些列函数被清除了，导致表不能用。    现请求：保留汇总表各列的函数不被清除，这样表格才能实现其它的计算判断功能。

谢谢！！

最佳答案

月排行榜 / 总排行榜

grf1973

2017-2-10 14:53

只要把涉及K列的输出删掉即可。
原代码中引用工作表名改为引用索引或当前工作表。

1. Sub 数据转移()
   
2.     Dim arr, result1, result2, result3, result4
   
3.     Dim k As Long
   
4.     Dim x As Long
   
5.     Dim i As Long
   
6.     Dim cnt As Long
   
7.     Dim temp As String
   
8.     Dim wb As Workbook
   
9.     Application.ScreenUpdating = False
   
10.     Set wb = Workbooks.Open(ThisWorkbook.Path & "\登记表")
    
11.     k = Cells(Rows.Count, 3).End(xlUp).Row
    
12.     arr = wb.Sheets(1).Range("b3:d" & k).Value
    
13.     wb.Close 0
    
14.     ReDim result1(1 To UBound(arr), 1 To 1)
    
15.     ReDim result2(1 To UBound(arr), 1 To 1)
    
16.     ReDim result3(1 To UBound(arr), 1 To 1)
    
17.     ReDim result4(1 To UBound(arr), 1 To 1)
    
18.     For x = 2 To UBound(arr)
    
19.         If arr(x, 2) <> "" Then
    
20.             Debug.Print arr(x, 2)
    
21.             cnt = cnt + 1
    
22.             If arr(x, 1) <> "" Then
    
23.                 result1(cnt, 1) = arr(x, 1)
    
24.                 temp = arr(x, 3)
    
25.             Else:
    
26.                 result1(cnt, 1) = result1(cnt - 1, 1)
    
27.             End If
    
28.             result2(cnt, 1) = "'" & temp
    
29.             result3(cnt, 1) = arr(x, 2)
    
30.             result4(cnt, 1) = "'" & arr(x, 3)
    
31.         End If
    
32.     Next x
    
33.     With ActiveSheet
    
34.         .Range("i2").Resize(UBound(arr), 1) = result1
    
35.         '.Range("k2").Resize(UBound(arr), 1) = result2
    
36.         .Range("m2").Resize(UBound(arr), 1) = result3
    
37.         .Range("u2").Resize(UBound(arr), 1) = result4
    
38.     End With
    
39.     Application.ScreenUpdating = True
    
40. End Sub
    

复制代码

跳转到最佳答案楼层

grf1973

只要把涉及K列的输出删掉即可。
原代码中引用工作表名改为引用索引或当前工作表。

1. Sub 数据转移()
   
2.     Dim arr, result1, result2, result3, result4
   
3.     Dim k As Long
   
4.     Dim x As Long
   
5.     Dim i As Long
   
6.     Dim cnt As Long
   
7.     Dim temp As String
   
8.     Dim wb As Workbook
   
9.     Application.ScreenUpdating = False
   
10.     Set wb = Workbooks.Open(ThisWorkbook.Path & "\登记表")
    
11.     k = Cells(Rows.Count, 3).End(xlUp).Row
    
12.     arr = wb.Sheets(1).Range("b3:d" & k).Value
    
13.     wb.Close 0
    
14.     ReDim result1(1 To UBound(arr), 1 To 1)
    
15.     ReDim result2(1 To UBound(arr), 1 To 1)
    
16.     ReDim result3(1 To UBound(arr), 1 To 1)
    
17.     ReDim result4(1 To UBound(arr), 1 To 1)
    
18.     For x = 2 To UBound(arr)
    
19.         If arr(x, 2) <> "" Then
    
20.             Debug.Print arr(x, 2)
    
21.             cnt = cnt + 1
    
22.             If arr(x, 1) <> "" Then
    
23.                 result1(cnt, 1) = arr(x, 1)
    
24.                 temp = arr(x, 3)
    
25.             Else:
    
26.                 result1(cnt, 1) = result1(cnt - 1, 1)
    
27.             End If
    
28.             result2(cnt, 1) = "'" & temp
    
29.             result3(cnt, 1) = arr(x, 2)
    
30.             result4(cnt, 1) = "'" & arr(x, 3)
    
31.         End If
    
32.     Next x
    
33.     With ActiveSheet
    
34.         .Range("i2").Resize(UBound(arr), 1) = result1
    
35.         '.Range("k2").Resize(UBound(arr), 1) = result2
    
36.         .Range("m2").Resize(UBound(arr), 1) = result3
    
37.         .Range("u2").Resize(UBound(arr), 1) = result4
    
38.     End With
    
39.     Application.ScreenUpdating = True
    
40. End Sub
    

复制代码

laoau138

grf1973 发表于 2017-2-10 14:53
只要把涉及K列的输出删掉即可。
原代码中引用工作表名改为引用索引或当前工作表。

http://www.excelpx.com/thread-427650-1-1.html

VBA计算等距离间隔循环相同数字