Board logo

標題: [發問] 分割資料成為新增工作表 [打印本頁]
作者: b9208    時間: 2011-2-1 10:50     標題: 分割資料成為新增工作表

各位先進您好
請問如何依照工作表內之特定儲存格資料，
分割資料成為新增工作表並置於原工作表之後，
更改新增工作表名稱為儲存格資料，同活頁簿內，如附件說明。
祝大家新年快樂，心想事成，宏兔大展。
[attach]4625[/attach][attach]4625[/attach]
作者: Hsieh    時間: 2011-2-1 12:15

回復 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    時間: 2011-2-1 14:11

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

謝謝
作者: Hsieh    時間: 2011-2-1 14:16

指定新增工作表位置
With Sheets.Add(after:=Sheets(Sheets.Count))
作者: b9208    時間: 2011-2-1 15:32

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

回復 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    時間: 2011-2-1 17:27

Dear Hsieh

vba程式執行ok

非常感謝您
作者: b9208    時間: 2011-2-1 22:50

回復 6# Hsieh

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

[attach]4630[/attach]
作者: Hsieh    時間: 2011-2-1 23:48

回復 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    時間: 2011-2-7 17:47

回復 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]欄位之資料都是被格式化成文字的數字，
在排序選項中〞將任何看似數字的項目視為數字來排列〞此選項可以完成。
請教要如何修改程式碼。

非常感謝
作者: Hsieh    時間: 2011-2-7 17:51

回復 10# b9208


   錄製巨集後去了解各個參數，就會有答案
作者: b9208    時間: 2011-2-7 19:02

回復 11# Hsieh

非常感謝指導
修訂如下：
.[A6].Resize(j, 15).Sort Key1:=.[M5], Order1:=xlAscending, Header:=xlNo, MatchCase:=False, DataOption1:=xlSortTextAsNumbers



歡迎光臨 麻辣家族討論版版 (http://forum.twbts.com/)