求各位大神帮忙解决下查询系统然后复制，帮忙给个代码，谢谢！

流浪雨

第一，把球队所在行的数据保存到对应的工作表中
第二，保存后按伦次排序
第三，各工作表名都放到A1里
第四，各工作表中的第二行和SHEET1中第二行的名称一样

liulang0808

1. Sub test()
   
2.     Set d = CreateObject("scripting.dictionary")
   
3.     Application.ScreenUpdating = False
   
4.     With Sheets("英超")
   
5.         arr = .UsedRange
   
6.         For j = 3 To UBound(arr)
   
7.              Str1 = Replace(Split(arr(j, 3), "]")(1), " ", "")
   
8.              If d.Exists(Str1) Then
   
9.                 Set d(Str1) = Union(d(Str1), .Cells(j, 1).Resize(1, 12))
   
10.              Else
    
11.                 Set d(Str1) = Union(.Cells(1, 1).Resize(2, 12), .Cells(j, 1).Resize(1, 12))
    
12.              End If
    
13.              str2 = Replace(Split(arr(j, 5), "[")(0), " ", "")
    
14.              If d.Exists(str2) Then
    
15.                 Set d(str2) = Union(d(str2), .Cells(j, 1).Resize(1, 12))
    
16.              Else
    
17.                 Set d(str2) = Union(.Cells(1, 1).Resize(2, 12), .Cells(j, 1).Resize(1, 12))
    
18.              End If
    
19.         Next j
    
20.     End With
    
21.     For j = 0 To d.Count - 1
    
22.         d.Items()(j).Copy Sheets(d.Keys()(j)).[a1]
    
23.     Next j
    
24.     Application.ScreenUpdating = True
    
25. End Sub
    

复制代码

liulang0808

楼主的队伍名称规范，可以提取，如果有其他不规范字符，就针对性处理吧
附件供参考

流浪雨

liulang0808 发表于 2019-4-14 09:21
楼主的队伍名称规范，可以提取，如果有其他不规范字符，就针对性处理吧
附件供参考

谢谢老师的帮忙，问题已解决，十分感谢！！！

lsc900707

按列拆分的问题呗，论坛里有很多实例的。

流浪雨

lsc900707 发表于 2019-4-14 09:45
按列拆分的问题呗，论坛里有很多实例的。

谢谢版主提醒，下次有问题了先去论坛搜下相关的帖子，

蓝桥玄霜

请见代码。

流浪雨

liulang0808 发表于 2019-4-14 09:21
楼主的队伍名称规范，可以提取，如果有其他不规范字符，就针对性处理吧
附件供参考

请教老师，有个别队伍缺少第三轮数据是什么原因？？？

流浪雨

蓝桥玄霜 发表于 2019-4-14 10:10
请见代码。

老师您好，您的代码有问题，只能保存主队数据，客队数据保存不上，能帮忙查下问题出在哪么，万分感谢！！！

一指禅62

1. Dim arr
   
2. 
   
3. Sub 数据拆分()
   
4.     Dim Sh As Worksheet, i&
   
5.     With Sheets("英超")
   
6.         i = .Range("A" & Rows.Count).End(3).Row
   
7.         arr = .Range("A1:M" & i)
   
8.     End With
   
9.     Application.ScreenUpdating = False
   
10.     For Each Sh In Worksheets
    
11.         If Sh.Name <> "英超" Then
    
12.             Call 生成成绩表(Sh)
    
13.         End If
    
14.     Next
    
15.     Application.ScreenUpdating = True
    
16. End Sub
    
17. 
    
18. Private Sub 生成成绩表(ByVal Sh As Object)
    
19.     Dim i&, j%, a(), n%
    
20.     For i = 3 To UBound(arr)
    
21.         If arr(i, 3) Like "*" & Sh.Name & "*" Or arr(i, 5) Like "*" & Sh.Name & "*" Then
    
22.             n = n + 1: ReDim Preserve a(1 To 13, 1 To n)
    
23.             For j = 1 To UBound(arr, 2)
    
24.                 a(j, n) = arr(i, j)
    
25.             Next
    
26.         End If
    
27.     Next
    
28.     With Sh.Range("A2:Z1000")
    
29.         .ClearContents
    
30.         .Borders.LineStyle = xlNone
    
31.     End With
    
32.     If n > 0 Then
    
33.         With Sh.Range("A2").Resize(n, 13)
    
34.             .Value = WorksheetFunction.Transpose(a)
    
35.             .Borders.LineStyle = xlContinuous
    
36.         End With
    
37.         Sh.Columns("A:M").Columns.AutoFit
    
38.     End If
    
39. End Sub

复制代码