请用数组法修改一段代码

天地一相

感谢帮助。请用数组办法修改原代码，功能操作不变。原代码：

1. For c = 1 To Application.WorksheetFunction.CountA(Sheet4.Rows("1:1")) - 2
   
2. Sheet3.Range("C1:C520").Value = Sheet4.Range(Sheet4.Cells(1, c), Sheet4.Cells(520, c)).Value
   
3. For d = c + 1 To Application.WorksheetFunction.CountA(Sheet4.Rows("1:1")) - 1
   
4. Sheet3.Range("D1:D520").Value = Sheet4.Range(Sheet4.Cells(1, d), Sheet4.Cells(520, d)).Value
   
5. For e = d + 1 To Application.WorksheetFunction.CountA(Sheet4.Rows("1:1"))
   
6. Sheet3.Range("E1:E520").Value = Sheet4.Range(Sheet4.Cells(1, e), Sheet4.Cells(520, e)).Value
   
7. Next e, d, c

复制代码

格调是我

    您好！根据您提供的VBA代码，我将使用数组方法来重写它：

```vba
Dim dataRange As Range
Dim dataArray() As Variant

' 获取数据范围
Set dataRange = Sheet4.Rows("1:520")

' 将数据范围的值存储到数组中
dataArray = dataRange.Value

' 外层循环，遍历列 c
For c = 1 To Application.WorksheetFunction.CountA(Sheet4.Rows("1:1")) - 2
   ' 内层循环1，遍历列 d
   For d = c + 1 To Application.WorksheetFunction.CountA(Sheet4.Rows("1:1")) - 1
      ' 内层循环2，遍历列 e
      For e = d + 1 To Application.WorksheetFunction.CountA(Sheet4.Rows("1:1"))
         ' 将特定列的数据存储到目标范围
         Sheet3.Range("C1:C520").Value = ArrayColumns(dataArray, c)
         Sheet3.Range("D1:D520").Value = ArrayColumns(dataArray, d)
         Sheet3.Range("E1:E520").Value = ArrayColumns(dataArray, e)
      Next e
   Next d
Next c

' 根据列索引，从二维数组中获取指定列的数据
Function ArrayColumns(dataArray As Variant, columnIndex As Integer) As Variant
   Dim resultArray() As Variant
   Dim i As Long
   
   ReDim resultArray(1 To UBound(dataArray, 1), 1 To 1)
   
   ' 将指定列的数据复制到结果数组中
   For i = 1 To UBound(dataArray, 1)
      resultArray(i, 1) = dataArray(i, columnIndex)
   Next i
   
   ArrayColumns = resultArray
End Function
```

请将上述代码替换原来的代码。这段代码使用了数组方法，通过一次获取数据并存储到数组中，然后使用数组操作进行处理，可以提高代码运行效率。

ykcbf1100

看着眼晕，代码可读性太差了。
代码不是行数越少越好，而是应该可读性好才是真的好，不然，后期维护累死人。

天地一相

ykcbf1100 发表于 2023-6-27 21:04
看着眼晕，代码可读性太差了。
代码不是行数越少越好，而是应该可读性好才是真的好，不然，后期维护累死人 ...

谢谢，不会吧，是本站一个高手帮我写的，简单直观易懂，我一下就看明白了。只是感觉速度不快，想着寻个数组的方法改写一下提速提速。数组你擅长呀，帮写一下呗。

天地一相

格调是我 发表于 2023-6-27 20:01
您好！根据您提供的VBA代码，我将使用数组方法来重写它：

```vba

谢谢，水平有限，稀里糊涂装进去测试，（貌似还有自定义函数什么的），ByRef报警。

fzxba

1. Sub test0() '不比原来的快，只是易看些，我用数组写更耗时点，故不用
   
2.   Dim Ran As Range, a As Long, b As Long, c As Long, d As Long, e As Long
   
3.   With Sheet4
   
4.     a = 520
   
5.     b = .Cells(1, .Columns.Count).End(xlToLeft).Column
   
6.     Set Ran = .Range("A1").Resize(a, b)
   
7.   End With
   
8.   With Sheet3
   
9.     For c = 1 To b - 2
   
10.       .Range("C1").Resize(a) = Ran.Columns(c).Value
    
11.       For d = c + 1 To b - 1
    
12.         .Range("D1").Resize(a) = Ran.Columns(d).Value
    
13.         For e = d + 1 To b
    
14.           .Range("E1").Resize(a) = Ran.Columns(e).Value
    
15.     Next e, d, c
    
16.   End With
    
17.   Set Ran = Nothing
    
18. End Sub

复制代码

天地一相

fzxba 发表于 2023-6-28 10:42

谢谢，我也发现这部分使用数组没速度上的改善，计算这一句无解，现在想大概汇总结果这部分有空间改善了，因为目前使用的是每符合一组数据就提取汇总写入一组，想着若把符合的先暂时写入数组，结束时一次性写入会更好点。请看下代码，可否修改下。

1. If Application.WorksheetFunction.CountBlank(Sheet2.Range("B2:B7")) < 6 Then
   
2.         For k = 2 To 7
   
3.         If Application.WorksheetFunction.CountBlank(Sheet2.Cells(k, "B")) < 1 Then
   
4.            n = n + 1
   
5.            Sheet1.Cells(n, 1).Value = Sheet3.Range("C1").Value & "-" & Sheet3.Range("D1").Value & "-" & Sheet3.Range("E1").Value
   
6.            Sheet1.Range(Sheet1.Cells(n, "B"), Sheet1.Cells(n, "AH")).Value = Sheet2.Range(Sheet2.Cells(k, "A"), Sheet2.Cells(k, "AG")).Value
   
7.         End If
   
8.         Next k
   
9.         End If

复制代码