排课表——怎么把这个txt文件的信息填到xls里去

wengjl

wengjl

因为我不会 VBA读 TXT文档的代码，所以，先手工做一步，文本文档中全选，复制，到EXCEL中粘贴，
再用以下二段代码解决转换问题

Sub dm1()
    ' https://club.excelhome.net/threa ... tml?_dsign=da6ca091
    ' 2024-7-24
    ' 先将txt课表，手工粘贴到EXCEL后，再转成一课一单元格
    For x = 1 To 167
      k = 2
      m = 2
      aa = Sheet1.Cells(x, 1).Value
      aa = Replace(aa, " ", "")
      If Len(aa) < 10 Then
        Sheet1.Cells(x, 2).Value = aa
      Else
        For i = 2 To Len(aa)
          If Mid(aa, i, 1) = "│" Then
            Sheet1.Cells(x, m).Value = Mid(aa, k, i - k)
            k = i + 1
            m = m + 1
          End If
        Next i
      End If
    Next x
End Sub

Sub dm2()
    ' https://club.excelhome.net/threa ... tml?_dsign=da6ca091
    ' 将 dm1 转后的课表，转成总课表
    ' 2024-7-24
    x3 = 2
    For i = 1 To 167 Step 28
      x3 = x3 + 1
      Sheet3.Cells(x3, 2).Value = Sheet1.Cells(i, 2).Value
      For xq = 1 To 5
        For jc = 1 To 7
          Sheet3.Cells(x3, (xq - 1) * 7 + 2 + jc).Value = Sheet1.Cells(i + Sheet1.Cells(jc, 11).Value, xq + 2).Value
        Next jc
      Next xq
    Next i
    MsgBox "OK！"
End Sub

wengjl

因公司电脑装有加密，上传只是传达一个信息，贴代码是有原因的

chxw68

1. Sub test()
   
2.     Dim r%, i%, m%
   
3.     Dim arr, brr, crr(1 To 10000, 1 To 6), zrr()
   
4.     Dim mypath$, myname$
   
5.     Application.ScreenUpdating = False
   
6.     Application.DisplayAlerts = False
   
7.     mypath = ThisWorkbook.Path & ""
   
8.     myname = "1.txt"
   
9.     If Dir(mypath & myname) = "" Then
   
10.         MsgBox "1.txt文件不存在！"
    
11.         Exit Sub
    
12.     End If
    
13.     Open mypath & myname For Input As #1
    
14.     arr = Split(StrConv(InputB(LOF(1), 1), vbUnicode), vbCrLf)
    
15.     Close #1
    
16.     m = 0
    
17.     x = 0
    
18.     For i = 0 To UBound(arr)
    
19.         ss = Replace(arr(i), Space(1), "")
    
20.         If InStr(ss, "课表") <> 0 Then
    
21.             m = m + 1
    
22.             x = x + 1
    
23.             crr(m, 1) = ss
    
24.             ReDim Preserve zrr(1 To x)
    
25.             zrr(x) = Array(m, m)
    
26.         ElseIf InStr(ss, "│") <> 0 Then
    
27.             brr = Split(ss, "│")
    
28.             If UBound(brr) = 7 Then
    
29.                 m = m + 1
    
30.                 For j = 1 To 6
    
31.                     crr(m, j) = brr(j)
    
32.                 Next
    
33.                 If x > 0 Then
    
34.                     zrr(x)(1) = m
    
35.                 End If
    
36.             End If
    
37.         End If
    
38.     Next
    
39.     ls = 3 + 5 * 7
    
40.     ReDim drr(1 To UBound(zrr), 1 To ls)
    
41.     For k = 1 To UBound(zrr)
    
42.         drr(k, 1) = crr(zrr(k)(0), 1)
    
43.         For j = 2 To UBound(crr, 2)
    
44.             n1 = j * 7 - 10
    
45.             n2 = 0
    
46.             For i = zrr(k)(0) + 2 To zrr(k)(1) Step 2
    
47.                 n2 = n2 + 1
    
48.                 drr(k, n1 + n2 - 1) = crr(i, j) & vbLf & crr(i + 1, j)
    
49.             Next
    
50.         Next
    
51.     Next
    
52.     With Worksheets("七年级")
    
53.         .Cells.Clear
    
54.         With .Range("a1")
    
55.             .Value = "课时班级"
    
56.             .Resize(2, 1).Merge
    
57.         End With
    
58.         n = 4
    
59.         For i = 1 To 5
    
60.             With .Cells(1, n)
    
61.                 .Value = "周" & Application.Text(i, "[DBnum1]")
    
62.                 .Resize(1, 7).Merge
    
63.             End With
    
64.             .Cells(2, n).Resize(1, 7) = Array(1, 2, 3, 4, 5, 6, 7)
    
65.             n = n + 7
    
66.         Next
    
67.         .Range("a3").Resize(UBound(drr), UBound(drr, 2)) = drr
    
68.         With .Range("a1").Resize(2 + UBound(drr), UBound(drr, 2))
    
69.             .Borders.LineStyle = xlContinuous
    
70.             With .Font
    
71.                 .Name = "微软雅黑"
    
72.                 .Size = 11
    
73.             End With
    
74.         End With
    
75.         With .UsedRange
    
76.             .HorizontalAlignment = xlCenter
    
77.             .VerticalAlignment = xlCenter
    
78.         End With
    
79.     End With
    
80. End Sub
    

复制代码

chxw68

确实用些繁琐。

chxw68

简化一下代码。