批量填写排课卡片

jx928867128 · 发表于 2024-3-13 10:19

本帖最后由 jx928867128 于 2024-3-16 08:06 编辑

鄂龙蒙 · 发表于 2024-3-13 10:47

搞不清楼主要做什么。。。。。。。。。。。。。

jx928867128 · 发表于 2024-3-13 11:15

本帖最后由 jx928867128 于 2024-3-13 11:40 编辑

鄂龙蒙发表于 2024-3-13 10:47
搞不清楼主要做什么。。。。。。。。。。。。。

谢谢您的关注，汇总表中的排课卡片是人工填写的，现在需要程序按课程总表中课程的位置将排课卡片填写在汇总表中

蓝桥玄霜 · 发表于 2024-3-13 12:19

课程的例子：

jx928867128 · 发表于 2024-3-13 16:26

本帖最后由 jx928867128 于 2024-3-13 17:20 编辑

蓝桥玄霜发表于 2024-3-13 12:19
课程的例子：

Sub lqxs()
Dim Arr, i&, x$, y$, Ls$, aa, Brr, Myr%, Myc%, Crr
Dim d, k, t, dl, xq$, m%, jjx, js$, xk$
Application.ScreenUpdating = False
Set d = CrereateObject("Scripting Dictionary")
Set d1 = CreateDateObject("Seripting.Dictionary")
Sheets("汇总").Activate
[b5:da50].ClearContents
Arr = Sheetss("排课卡片").[al].CurrentRegion
For i = 1 To UUBound(Arr)
x = Arr(i, 1)
For j = 2 To UBound(Arr, 2)
      If Arr(i, j) <> "" Then
         aa = Split(Arr(i, j), Chr(10))
         y = aa(0): Ls = aa(1)
         If d.exists(x) = False Then Set d(x) = CreateObject("Scripting Dictionary")
         d(x)(y) = Ls
      End If
Next
Next
k = d.keys: t = d.items
Myr = Sheet6.Cells(Sheet6.Rows.Count, 1).End(xlUp).Row
Myc = Sheet6.[iv4].End(x17ToLeft).Column
Brr = Sheet6.Range("a3").Resize(Myr, Mye)
For i = 3 To UBound(Brr)
x = Brr(i, 1)
For j = 2 To UBound(Brr, 2)
If Sheet6.Cells(3, j).MergeCells Then
      xq = Brr(1, j)
      m = Sheet6.Cells(3, j).MergeArea.Columns.Count
      For jj = j To j + m - 1
         js = Brr(2, jj): xk = Brr(i, jj)
         If xk <> "" Then
            y = xq & "|" & js
            dl(x & "|" & y) = xk
         End If
      Next
End If
j = j + m - 1
Next
Myr = Cells(Rows.Count, 1).End(xlUp).Row
Myc = [iv4].End(xlToLeft).Column
Crr = Range("a3").Resize(Myr, Myc)
For i = 3 To UBound(Crr)
x = Crr(i, 1)
If d.exists(x) Then
      For j = 2 To UBound(Crr, 2)
         If Cells(3, j).MaergeCells Then
            xq = Crr(1, j)
            m = Cells(3, j).MergeArea.Columns.Count
            For jj = j To j + m - l
                  js = Crr(2, jj)
                  y = xq & "|" & js
                  If dl.exists(x & "|" & y) Then
                     xk = dl(x & "|" & y)
                     Ls = d(x)(xk)
                     Cells(i + 2, jj) = xk & Chr(10) & Ls
                  End If
            Next
         End If
         j = j + m - l
      Next
End If
Next
MsgBox "OK"
Application.ScreenUpdating = Tru
End Sub

jx928867128 · 发表于 2024-3-13 16:26

蓝桥玄霜发表于 2024-3-13 12:19
课程的例子：

谢谢版主帮忙，我抄了您的代码，不知哪里出错了，程序不能运行

3190496160 · 发表于 2024-3-13 17:51

Sub 汇总表()
Application.ScreenUpdating = False
Dim arr As Variant, brr As Variant
Dim crr()
Dim d As Object
Set d = CreateObject("scripting.dictionary")
With Sheets("排课卡片")
r = .Cells(.Rows.Count, "a").End(xlUp).Row
c = .UsedRange.Columns.Count
arr = .[a1].Resize(r, c)
End With
For i = 1 To UBound(arr)
For j = 2 To UBound(arr, 2)
      If arr(i, j) <> "" Then
         If InStr(arr(i, j), Chr(10)) > 0 Then
            rr = Split(arr(i, j), Chr(10))
            w_1 = rr(0)
            w_2 = rr(1)
            zd = arr(i, 1) & "|" & w_1
            d(zd) = w_2
         End If
      End If
Next j
Next i
With Sheets("课程总表")
rs = .Cells(.Rows.Count, "a").End(xlUp).Row
cs = .UsedRange.Columns.Count
brr = .[a1].Resize(rs, cs)
End With
ReDim crr(1 To UBound(brr), 1 To UBound(brr, 2))
For i = 5 To UBound(brr)
If brr(i, 1) <> "" Then
      n = n + 1
      crr(n, 1) = brr(i, 1)
      For j = 2 To UBound(brr, 2)
         If brr(i, j) <> "" Then
            zd = brr(i, 1) & "|" & brr(i, j)
            If d.exists(zd) Then
                  crr(n, j) = brr(i, j) & Chr(10) & d(zd)
            Else
                  crr(n, j) = brr(i, j)
            End If
         End If
      Next j
End If
Next i
With Sheets("汇总")
.UsedRange.Offset(4).Clear
.[a5].Resize(n, UBound(crr, 2)) = crr
.[a5].Resize(n, UBound(crr, 2)).Borders.LineStyle = 1
End With
Application.ScreenUpdating = True
MsgBox "ok!"
End Sub

3190496160 · 发表于 2024-3-13 17:52

按课程位置自动填写排课卡片.rar (27.08 KB, 下载次数: 21)

fzxba · 发表于 2024-3-13 19:18

Sub 老师辛苦了()

  Dim ar, br, cr, dict As Object, s As String
  Dim i As Long, j As Long, p As Long, t

  Application.ScreenUpdating = False

  ar = Sheet5.Range("A1").CurrentRegion '排课卡片
  br = Sheet2.Range("A3").CurrentRegion '汇总
  cr = Sheet6.Range("A3").CurrentRegion '课程总表

  Set dict = CreateObject("Scripting.Dictionary")

  For i = 3 To UBound(cr)
s = Trim(cr(i, 1))
If Len(s) Then dict.Add s, i
cr(i, 1) = s
  Next

  For i = 1 To UBound(ar)
For j = 2 To UBound(ar, 2)
   s = Trim(ar(i, j))
   If Len(s) Then
      If Not dict.Exists(ar(i, 1) & Left(s, 2)) Then dict.Add ar(i, 1) & Left(s, 2), Array(i, j)
   End If
Next
  Next

  For i = 3 To UBound(br)
p = dict(br(i, 1))
If p Then
   For j = 2 To UBound(cr, 2)
      s = Trim(cr(p, j))
      If Len(s) Then
      If dict.Exists(cr(p, 1) & Left(s, 2)) Then
         t = dict(cr(p, 1) & Left(s, 2))
         br(i, j) = ar(t(0), t(1))
      Else
         br(i, j) = ""
      End If
      End If
   Next
End If
  Next

  Worksheets("汇总").Range("A12").Resize(UBound(br), UBound(br, 2)) = br

  Application.ScreenUpdating = True
  Set dict = Nothing
  Beep
End Sub

fzxba · 发表于 2024-3-13 19:23

本帖最后由 fzxba 于 2024-3-13 21:08 编辑

改一下加上清空语句.zip (33.89 KB, 下载次数: 18)

		自动登录	找回密码
密码			免费注册

[求助] 批量填写排课卡片

评分

评分

评分