求大侠帮忙实现合并单元格，见附件。谢谢

ahhfmx

                                          


求助课表中如何自动合并单元格.rar (29.89 KB, 下载次数: 45)

2014-4-11 14:37 上传

点击文件名下载附件

                           

cmxxccxx

这种合并，用公式的话需要用较多的辅助列，建议使用VB

ahhfmx

cmxxccxx 发表于 2014-4-11 15:49
这种合并，用公式的话需要用较多的辅助列，建议使用VB

感谢第一时间回复！VB也可，求解。谢谢！

ahhfmx

用函数加辅助列也可啊，求帮忙啊！

w08042230

路过，帮顶

ahhfmx

问题没有解决啊！继续求高手帮忙啊

蓝桥玄霜

1. Application.ScreenUpdating = False
   
2. Set d = CreateObject("Scripting.Dictionary")
   
3. xinq = Array("星期一", "星期二", "星期三", "星期四", "星期五")
   
4. col = Array("1、2", "3、4", "5、6", "7、8", "9、10")
   
5. Sheet3.Activate
   
6. [b4:b500].ClearContents
   
7. [d4:ab500].ClearContents
   
8. Arr = Sheet1.[a1].CurrentRegion
   
9. For j = 3 To UBound(Arr, 2) Step 5
   
10.     xq = Arr(3, j)   '星期
    
11.     For b = j To j + 4
    
12.         For i = 7 To UBound(Arr) - 1 Step 3
    
13.             x = Arr(i, b)
    
14.             If x <> "" Then
    
15.                 y = Arr(i - 1, b) & "," & Arr(i + 1, b)   '课程和场地
    
16.                 If d.exists(x) = False Then Set d(x) = CreateObject("Scripting.Dictionary")
    
17.                 d(x)(y) = d(x)(y) & Arr(i - 1, 1) & "," & xq & " " & Arr(5, b) & "|"
    
18.             End If
    
19.         Next
    
20.     Next
    
21. Next
    
22. k = d.keys: t = d.items: n = 1
    
23. For i = 0 To UBound(k)
    
24.     n = n + 3
    
25.     Cells(n, 2) = k(i)
    
26.     kk = t(i).keys: tt = t(i).items
    
27.     For j = 0 To UBound(tt)
    
28.         kc = Split(kk(j), ",")
    
29.         tt(j) = Left(tt(j), Len(tt(j)) - 1)
    
30.         If InStr(tt(j), "|") Then
    
31.             aa = Split(tt(j), "|")
    
32.             For jj = 0 To UBound(aa)
    
33.                 a = Split(aa(jj), ",")
    
34.                 bj = a(0)
    
35.                 q = Split(a(1))(0)
    
36.                 c = Split(a(1))(1)
    
37.                 m = Application.Match(q, xinq, 0) - 1
    
38.                 m1 = Application.Match(c, col, 0) - 1
    
39.                 cc = 5 * m + 4 + m1
    
40.                 If Cells(n, cc) = "" Then
    
41.                     Cells(n, cc) = bj
    
42.                     Cells(n + 1, cc) = kc(0)
    
43.                     Cells(n + 2, cc) = kc(1)
    
44.                 Else
    
45.                     Cells(n, cc) = Cells(n, cc) & vbCrLf & bj
    
46.                 End If
    
47.             Next
    
48.         Else
    
49.             a = Split(tt(j), ",")
    
50.             bj = a(0)
    
51.             q = Split(a(1))(0)
    
52.             c = Split(a(1))(1)
    
53.             m = Application.Match(q, xinq, 0) - 1
    
54.             m1 = Application.Match(c, col, 0) - 1
    
55.             cc = 5 * m + 4 + m1
    
56.             Cells(n, cc) = bj
    
57.             Cells(n + 1, cc) = kc(0)
    
58.             Cells(n + 2, cc) = kc(1)
    
59.         End If
    
60.     Next
    
61. Next
    
62. Application.ScreenUpdating = True
    

复制代码

蓝桥玄霜

请见附件。

lhx120824

在教师总课程表中，
D4单元格输入数组公式公式
=IFERROR(INDEX(课程手工安排!$A$1:$A$50,SMALL(IF(课程手工安排!C$1:C$50=$B4,ROW($1:$50)-1,99),1),),"")&"  "&IFERROR(INDEX(课程手工安排!$A$1:$A$50,SMALL(IF(课程手工安排!C$1:C$50=$B4,ROW($1:$50)-1,99),2),),"")&"  "&IFERROR(INDEX(课程手工安排!$A$1:$A$50,SMALL(IF(课程手工安排!C$1:C$50=$B4,ROW($1:$50)-1,99),3),),"")
D5单元格输入
=INDEX(课程手工安排!$C$1:$C$50,MATCH(B4,课程手工安排!$C$1:$C$50,0)-1,)
D6单元格输入
=INDEX(课程手工安排!$C$1:$C$50,MATCH(B4,课程手工安排!$C$1:$C$50,0)+1,)
然后选定D4:D6下拉复制填充即可。
其中的$C$1:$C$50以及99可根据情况变化范围.

lhx120824

见附件：
求助课表中如何自动合并单元格.rar (47.47 KB, 下载次数: 29)

2014-4-21 08:21 上传

点击文件名下载附件

公式IFERROR( ）需在版本2007及以上使用。
因为你的总课程表和手工排课表的结构是一样的，公式可以右拉。