[已解决]在同一工作薄下进行分类

qish1888

老师们好，我有一个表，每四行为一组，中间空一行。如图，
            要求：
            1、分类表在同一工作薄下
           2、按I、J两列的关健字进行分类。
           3、分类工作表的名称＝分类名称 如12123131、34341111、12122121
      

最佳答案

月排行榜 / 总排行榜

wanao2008

2016-12-27 21:56

请测试：

1. Sub wanao()
   
2.     Dim a As String, b As String, sName As Worksheet
   
3.     Dim x, shtExist As Boolean
   
4. For x = 3 To Cells(Rows.Count, "a").End(xlUp).Row Step 5
   
5.         shtExist = False
   
6.         a = Cells(x, "i") & Cells(x + 1, "i") & Cells(x + 2, "i") & Cells(x + 3, "i")
   
7.         b = Cells(x, "j") & Cells(x + 1, "j") & Cells(x + 2, "j") & Cells(x + 3, "j")
   
8.         For Each sName In Sheets
   
9.             aa = sName.Name
   
10.             If sName.Name = a & b Or sName.Name = b & a Then
    
11.                 shtExist = True
    
12.                 Exit For
    
13.             End If
    
14.         Next
    
15.         If shtExist = True Then
    
16.             Rows(x & ":" & x + 3).Copy
    
17.             sName.Activate
    
18.             Rows(sName.Cells(Rows.Count, "a").End(xlUp).Row + 2).Select
    
19.             ActiveSheet.Paste
    
20.             ActiveSheet.Name = a & b
    
21.         Else
    
22.             Rows(x & ":" & x + 3).Select
    
23.             Selection.Copy
    
24.             Sheets.Add After:=Sheets(Sheets.Count)
    
25.             Rows("1:1").Select
    
26.             ActiveSheet.Paste
    
27.             ActiveSheet.Name = a & b
    
28.         End If
    
29.         ThisWorkbook.Sheets(1).Activate
    
30.       
    
31.     Next
    
32. End Sub

复制代码

跳转到最佳答案楼层

wanao2008

请测试：

1. Sub wanao()
   
2.     Dim a As String, b As String, sName As Worksheet
   
3.     Dim x, shtExist As Boolean
   
4. For x = 3 To Cells(Rows.Count, "a").End(xlUp).Row Step 5
   
5.         shtExist = False
   
6.         a = Cells(x, "i") & Cells(x + 1, "i") & Cells(x + 2, "i") & Cells(x + 3, "i")
   
7.         b = Cells(x, "j") & Cells(x + 1, "j") & Cells(x + 2, "j") & Cells(x + 3, "j")
   
8.         For Each sName In Sheets
   
9.             aa = sName.Name
   
10.             If sName.Name = a & b Or sName.Name = b & a Then
    
11.                 shtExist = True
    
12.                 Exit For
    
13.             End If
    
14.         Next
    
15.         If shtExist = True Then
    
16.             Rows(x & ":" & x + 3).Copy
    
17.             sName.Activate
    
18.             Rows(sName.Cells(Rows.Count, "a").End(xlUp).Row + 2).Select
    
19.             ActiveSheet.Paste
    
20.             ActiveSheet.Name = a & b
    
21.         Else
    
22.             Rows(x & ":" & x + 3).Select
    
23.             Selection.Copy
    
24.             Sheets.Add After:=Sheets(Sheets.Count)
    
25.             Rows("1:1").Select
    
26.             ActiveSheet.Paste
    
27.             ActiveSheet.Name = a & b
    
28.         End If
    
29.         ThisWorkbook.Sheets(1).Activate
    
30.       
    
31.     Next
    
32. End Sub

复制代码

qish1888

谢谢WANA02008老师，你的无私奉献。

wanao2008

qish1888 发表于 2016-12-29 15:21
谢谢WANA02008老师，你的无私奉献。

别客气