[發問] 分割資料成為新增工作表

b9208

各位先進您好
請問如何依照工作表內之特定儲存格資料，
分割資料成為新增工作表並置於原工作表之後，
更改新增工作表名稱為儲存格資料，同活頁簿內，如附件說明。
祝大家新年快樂，心想事成，宏兔大展。
B2.rar (4.35 KB)

下載次數: 16

2011-2-1 10:50

Hsieh

回復 1# b9208

1. Sub Split_Sheet()
   
2. Dim Rng As Range, A As Range
   
3. Application.DisplayAlerts = False
   
4. With Sheets("WW")
   
5. .Select
   
6. p = ActiveWindow.Zoom
   
7. For Each sht In Sheets
   
8. If sht.Name <> .Name Then sht.Delete
   
9. Next
   
10. For Each A In .Range(.[F1], .Cells(.Rows.Count, 6).End(xlUp))
    
11.    If IsDate(A) Then
    
12.       If Rng Is Nothing Then
    
13.          Set Rng = A
    
14.          Else
    
15.          Set Rng = Union(Rng, A)
    
16.       End If
    
17.     End If
    
18. Next
    
19. Set Rng = Union(Rng, .Cells(.Rows.Count, 1).End(xlUp).Offset(2, 5))
    
20. For i = 1 To Rng.Areas.Count - 1
    
21.    Set myrng = .Range(Rng.Areas(i).Offset(-1, -5), Rng.Areas(i + 1).Offset(-2, 9))
    
22.    sh = myrng.Cells(2, 7)
    
23.    With Sheets.Add
    
24.    .Name = sh
    
25.    myrng.Copy .[A1]
    
26.    For j = 1 To myrng.Rows.Count
    
27.       .Rows(j).RowHeight = myrng.Rows(j).RowHeight
    
28.    Next
    
29.    For k = 1 To myrng.Columns.Count
    
30.       .Columns(k).ColumnWidth = myrng.Columns(k).ColumnWidth
    
31.    Next
    
32.    ActiveWindow.Zoom = p
    
33.    End With
    
34. Next
    
35. End With
    
36. Application.DisplayAlerts = True
    
37. End Sub

複製代碼

b9208

感謝 Hsieh 版主
執行ok
工作表排列可以如下方式：
WW, Mon, Tue, ......., Sun
目前排列 Sun, Sat, ........, WW

謝謝

Hsieh

指定新增工作表位置
With Sheets.Add(after:=Sheets(Sheets.Count))

b9208

Hsieh 版主
排列ok
但有另一問題，其他工作表都刪除了（除了WW及新增Mon, Tue,...）
同一檔案中含有其他的工作表
" If sht.Name <> .Name Then sht.Delete "
謝謝您

Hsieh

回復 5# b9208

1. Sub Split_Sheet()
   
2. Dim Rng As Range, A As Range
   
3. Application.DisplayAlerts = False
   
4. ar = Array("Mon", "Tue", "Wed", "Thu", "Fri", "Sat", "Sun")
   
5. With Sheets("WW")
   
6. .Select
   
7. p = ActiveWindow.Zoom
   
8. For Each sht In Sheets
   
9. If IsNumeric(Application.Match(sht.Name, ar, 0)) Then sht.Delete
   
10. Next
    
11. For Each A In .Range(.[F1], .Cells(.Rows.Count, 6).End(xlUp))
    
12.    If IsDate(A) Then
    
13.       If Rng Is Nothing Then
    
14.          Set Rng = A
    
15.          Else
    
16.          Set Rng = Union(Rng, A)
    
17.       End If
    
18.     End If
    
19. Next
    
20. Set Rng = Union(Rng, .Cells(.Rows.Count, 1).End(xlUp).Offset(2, 5))
    
21. For i = 1 To Rng.Areas.Count - 1
    
22.    Set myrng = .Range(Rng.Areas(i).Offset(-1, -5), Rng.Areas(i + 1).Offset(-2, 9))
    
23.    sh = myrng.Cells(2, 7)
    
24.    With Sheets.Add(after:=Sheets(Sheets.Count))
    
25.    .Name = sh
    
26.    myrng.Copy .[A1]
    
27.    For j = 1 To myrng.Rows.Count
    
28.       .Rows(j).RowHeight = myrng.Rows(j).RowHeight
    
29.    Next
    
30.    For k = 1 To myrng.Columns.Count
    
31.       .Columns(k).ColumnWidth = myrng.Columns(k).ColumnWidth
    
32.    Next
    
33.    ActiveWindow.Zoom = p
    
34.    End With
    
35. Next
    
36. End With
    
37. Application.DisplayAlerts = True
    
38. End Sub

複製代碼

b9208

Dear Hsieh

vba程式執行ok

非常感謝您

b9208

回復 6# Hsieh

版主您好
如增加清單資料表
由Mon~Sun工作表中，依照O欄資料，設定第一個字為E,M,R,T,U,S等，列出所需欄位資料。
如附件所示，謝謝

B2-1.rar (14.83 KB)

下載次數: 8

2011-2-1 22:49

Hsieh

回復 8# b9208

1. Sub Ex()
   
2. Dim Ay()
   
3. Dim Sh As Worksheet
   
4. For Each Sh In Sheets
   
5.    With Sh
   
6.    If IsNumeric(Application.Match(.Name, Array("Mon", "Tue", "Wed", "Thu", "Fri", "Sat", "Sun"), 0)) Then
   
7.       For Each A In .Range("O:O").SpecialCells(xlCellTypeConstants)
   
8.          If IsNumeric(Application.Match(Left(A, 1), Array("E", "M", "R", "S", "T", "U", "W"), 0)) Then
   
9.             ar = Array(Format(.[F2], "yyyy/mm/dd"), .Name, .Cells(A.Row, "E"), .Cells(A.Row, "G"), .Cells(A.Row, "H"), .Cells(A.Row, "I"), .Cells(A.Row, "J"), .Cells(A.Row, "K"), .Cells(A.Row, "M"), .Cells(A.Row, "N"), A)
   
10.             ReDim Preserve Ay(s)
    
11.             Ay(s) = ar
    
12.             s = s + 1
    
13.          End If
    
14.       Next
    
15.     End If
    
16.     End With
    
17. Next
    
18. With Sheets("Qt List")
    
19. If s > 0 Then .Cells(.Rows.Count, 1).End(xlUp).Offset(1, 0).Resize(s, 11) = Application.Transpose(Application.Transpose(Ay))
    
20. End With
    
21. End Sub

複製代碼

b9208

回復 6# Hsieh

Hsieh 版主
於分割後之工作表（Mon.........Sun)，依據[M5]之項目排序（由小至大，沒有標題列）
增加之程式碼如下：
With Sheets.Add(after:=Sheets(Sheets.Count))
    ............
     .[A6].Resize(j, 15).Sort Key1:=.[M5], Header:=xlNo
     ActiveWindow.Zoom = p
   End With

但[M5]欄位之資料都是被格式化成文字的數字，
在排序選項中〞將任何看似數字的項目視為數字來排列〞此選項可以完成。
請教要如何修改程式碼。

非常感謝