代码优化

328787483

请老师帮忙优化“覆盖图示”中的代码部分代码如下（F1到F49为变量）：

With Sheets("覆盖图示")
    .Cells(2, 2) = F1: .Cells(2, 3) = F2: .Cells(3, 2) = F3: .Cells(3, 3) = F4: .Cells(3, 4) = F5: .Cells(3, 5) = F6
    .Cells(4, 2) = F7: .Cells(4, 3) = F8: .Cells(4, 4) = F9: .Cells(4, 5) = F10: .Cells(4, 6) = F11: .Cells(4, 7) = F12: .Cells(4, 8) = F13: .Cells(4, 9) = F14
    .Cells(5, 2) = F15: .Cells(5, 3) = F16: .Cells(5, 4) = F17: .Cells(5, 5) = F18: .Cells(5, 6) = F19: .Cells(5, 7) = F20: .Cells(5, 8) = F21: .Cells(5, 9) = F22
    .Cells(5, 10) = F23: .Cells(5, 11) = F24: .Cells(5, 12) = F25: .Cells(5, 13) = F26
    .Cells(6, 2) = F27: .Cells(6, 3) = F28: .Cells(6, 4) = F29: .Cells(6, 5) = F30: .Cells(6, 6) = F31: .Cells(6, 7) = F32: .Cells(6, 8) = F33: .Cells(6, 9) = F34
    .Cells(6, 10) = F35: .Cells(6, 11) = F36: .Cells(6, 12) = F37
    .Cells(7, 2) = F38: .Cells(7, 3) = F39: .Cells(7, 4) = F40: .Cells(7, 5) = F41: .Cells(7, 6) = F42: .Cells(7, 7) = F43
    .Cells(8, 2) = F44: .Cells(8, 3) = F45: .Cells(8, 4) = F46: .Cells(8, 5) = F47: .Cells(8, 6) = F48: .Cells(8, 7) = F49
End With


网上也找不着，只能求助各位老师咯，谢谢！

yjh_27

Dim F1 As Byte, F2 As Byte, F3 As Byte, F4 As Byte, F5 As Byte, F6 As Byte, F7 As Byte, F8 As Byte, F9 As Byte, F10 As Byte
Dim F11 As Byte, F12 As Byte, F13 As Byte, F14 As Byte, F15 As Byte, F16 As Byte, F17 As Byte, F18 As Byte, F19 As Byte, F20 As Byte
Dim F21 As Byte, F22 As Byte, F23 As Byte, F24 As Byte, F25 As Byte, F26 As Byte, F27 As Byte, F28 As Byte, F29 As Byte, F30 As Byte
Dim F31 As Byte, F32 As Byte, F33 As Byte, F34 As Byte, F35 As Byte, F36 As Byte, F37 As Byte, F38 As Byte, F39 As Byte, F40 As Byte
Dim F41 As Byte, F42 As Byte, F43 As Byte, F44 As Byte, F45 As Byte, F46 As Byte, F47 As Byte, F48 As Byte, F49 As Byte
改为
Dim F(1 to 49)


F1 改f(1) .......


1L代码改
clm = Array(, , 3, 5, 9, 13, 12, 7, 7)
With Sheets("覆盖图示")
    k = 0
    For i = 2 To 7
    For j = 2 To clm(i)
        k = k + 1
        .Cells(i, j) = f(k)
    Next j, i
End With

microyip

1. Private Sub CommandButton1_Click()
   
2.     Dim wSH As Worksheet
   
3.     Dim vData As Variant, vFill As Variant
   
4.     Dim nCol As Long, nRow As Long, nI As Long
   
5.     Dim dicData As Object, dicSheet As Object
   
6.    
   
7.     '从填写内容看，就是不同表(7个表)不同行（7行），行数按“项点”对应表的最大序号（12）而定，建立填表数组
   
8.     With Application.WorksheetFunction
   
9.         vData = Sheets("项点").[A3:A51].Value
   
10.         nCol = .Max(.Transpose(vData))
    
11.         ReDim vFill(1 To 7, 1 To nCol)
    
12.     End With
    
13.     vData = Sheets("项点").[A3:D51].Value
    
14.     Set dicData = CreateObject("Scripting.Dictionary")
    
15.     nCol = 999
    
16.     For nI = 1 To UBound(vData)
    
17.         If vData(nI, 1) < nCol Then '序号小于存在的行数，表示要换表了
    
18.             nRow = nRow + 1 '填表换列
    
19.             Set dicData(nRow) = CreateObject("Scripting.Dictionary")
    
20.         End If
    
21.         nCol = vData(nI, 1)
    
22.         dicData(nRow)(vData(nI, 4)) = nCol '记录所在填表所在行数
    
23.     Next
    
24.     vData = Split("|出勤环节|库内接车环节|出入库调车环节|接、发车环节（含中间站）|运行中作业环节|调车作业环节|站停作业环节", "|")
    
25.     Set dicSheet = CreateObject("Scripting.Dictionary")
    
26.     For nRow = 1 To UBound(vData)
    
27.         dicSheet(vData(nRow)) = nRow '建立每个表所在行
    
28.     Next
    
29.    
    
30.     For Each wSH In Sheets
    
31.         With wSH
    
32.             If dicSheet.Exists(.Name) Then
    
33.                 nRow = dicSheet(.Name) '获取对应表所在行
    
34.                 nI = .Cells(.Rows.Count, 11).End(xlUp).Row
    
35.                 If nI > 2 Then
    
36.                     vData = .Cells(1, 9).Resize(nI).Value
    
37.                     For nI = 3 To UBound(vData)
    
38.                         If dicData(nRow).Exists(vData(nI, 1)) Then
    
39.                             nCol = dicData(nRow)(vData(nI, 1))
    
40.                             vFill(nRow, nCol) = vFill(nRow, nCol) + 1
    
41.                         End If
    
42.                     Next
    
43.                 End If
    
44.             End If
    
45.         End With
    
46.     Next
    
47.     Sheets("覆盖图示").Cells(2, 2).Resize(UBound(vFill), UBound(vFill, 2)) = vFill
    
48.     Application.ScreenUpdating = True
    
49. End Sub

复制代码

microyip

附上附件以供参考

328787483

microyip 发表于 2020-1-11 11:07
附上附件以供参考

谢谢，老师的帮助，虽然不是很理解，但好像出了点问题，出勤环节只有项点1、2，运行之后出勤环节项点5/6/7也出现的数据。

328787483

yjh_27 发表于 2020-1-10 23:31
Dim F1 As Byte, F2 As Byte, F3 As Byte, F4 As Byte, F5 As Byte, F6 As Byte, F7 As Byte, F8 As Byte,  ...

这是把F1到F49看成是数组F，我一直没转过弯来，谢谢老师！

microyip

328787483 发表于 2020-1-11 12:05
谢谢，老师的帮助，虽然不是很理解，但好像出了点问题，出勤环节只有项点1、2，运行之后出勤环节项点5/6/ ...

把你原来填写的那个行列误解反了，把对应代码对调一下参数就可以了，已经更新代码及附件，重新下载一下即可

328787483

microyip 发表于 2020-1-11 13:05
把你原来填写的那个行列误解反了，把对应代码对调一下参数就可以了，已经更新代码及附件，重新下载一下即 ...

谢谢老师

328787483

microyip 发表于 2020-1-11 13:05
把你原来填写的那个行列误解反了，把对应代码对调一下参数就可以了，已经更新代码及附件，重新下载一下即 ...

谢谢，老师，太厉害了handshake