12
返回列表 上一主題 發帖

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

b9208

帖子
182 
主題
34 
精華
0 
積分
316 
點名
0  
作業系統
Win 7 
軟體版本
Office 2010 
閱讀權限
20 
性別
男 
來自
Taiwan 
註冊時間
2010-5-2 
最後登錄
2023-6-24 
1# 跳轉到 » 倒序看帖
打印
tT
發表於 2011-2-1 10:50 | 只看該作者

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

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

Hsieh

帖子
4901 
主題
44 
精華
24 
積分
4916 
點名
91  
作業系統
Windows 7 
軟體版本
Office 20xx 
閱讀權限
150 
性別
男 
來自
台北 
註冊時間
2010-4-30 
最後登錄
2024-4-20 

2023年全勤獎章2022虎年全勤獎章2021牛年全勤獎章2020鼠年全勤獎章2019 豬年全勤獎章2018 狗年全勤獎章2017 雞年全勤獎章2016猴年全勤獎章2015羊年全勤獎章2014馬年全勤獎章2013蛇年全勤獎章2012龍年全勤獎章論壇貢獻勳章熱心公益勳章2011兔年全勤獎章
2#
發表於 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
複製代碼
學海無涯_不恥下問

TOP

b9208

帖子
182 
主題
34 
精華
0 
積分
316 
點名
0  
作業系統
Win 7 
軟體版本
Office 2010 
閱讀權限
20 
性別
男 
來自
Taiwan 
註冊時間
2010-5-2 
最後登錄
2023-6-24 
3#
發表於 2011-2-1 14:11 | 只看該作者
感謝 Hsieh 版主
執行ok
工作表排列可以如下方式：
WW, Mon, Tue, ......., Sun
目前排列 Sun, Sat, ........, WW

謝謝
100 字節以內
不支持自定義 Discuz! 代碼

TOP

Hsieh

帖子
4901 
主題
44 
精華
24 
積分
4916 
點名
91  
作業系統
Windows 7 
軟體版本
Office 20xx 
閱讀權限
150 
性別
男 
來自
台北 
註冊時間
2010-4-30 
最後登錄
2024-4-20 

2023年全勤獎章2022虎年全勤獎章2021牛年全勤獎章2020鼠年全勤獎章2019 豬年全勤獎章2018 狗年全勤獎章2017 雞年全勤獎章2016猴年全勤獎章2015羊年全勤獎章2014馬年全勤獎章2013蛇年全勤獎章2012龍年全勤獎章論壇貢獻勳章熱心公益勳章2011兔年全勤獎章
4#
發表於 2011-2-1 14:16 | 只看該作者
指定新增工作表位置
With Sheets.Add(after:=Sheets(Sheets.Count))
學海無涯_不恥下問

TOP

b9208

帖子
182 
主題
34 
精華
0 
積分
316 
點名
0  
作業系統
Win 7 
軟體版本
Office 2010 
閱讀權限
20 
性別
男 
來自
Taiwan 
註冊時間
2010-5-2 
最後登錄
2023-6-24 
5#
發表於 2011-2-1 15:32 | 只看該作者
Hsieh 版主
排列ok
但有另一問題，其他工作表都刪除了（除了WW及新增Mon, Tue,...）
同一檔案中含有其他的工作表
" If sht.Name <> .Name Then sht.Delete "
謝謝您
100 字節以內
不支持自定義 Discuz! 代碼

TOP

Hsieh

帖子
4901 
主題
44 
精華
24 
積分
4916 
點名
91  
作業系統
Windows 7 
軟體版本
Office 20xx 
閱讀權限
150 
性別
男 
來自
台北 
註冊時間
2010-4-30 
最後登錄
2024-4-20 

2023年全勤獎章2022虎年全勤獎章2021牛年全勤獎章2020鼠年全勤獎章2019 豬年全勤獎章2018 狗年全勤獎章2017 雞年全勤獎章2016猴年全勤獎章2015羊年全勤獎章2014馬年全勤獎章2013蛇年全勤獎章2012龍年全勤獎章論壇貢獻勳章熱心公益勳章2011兔年全勤獎章
6#
發表於 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
複製代碼
學海無涯_不恥下問

TOP

b9208

帖子
182 
主題
34 
精華
0 
積分
316 
點名
0  
作業系統
Win 7 
軟體版本
Office 2010 
閱讀權限
20 
性別
男 
來自
Taiwan 
註冊時間
2010-5-2 
最後登錄
2023-6-24 
7#
發表於 2011-2-1 17:27 | 只看該作者
Dear Hsieh

vba程式執行ok

非常感謝您
100 字節以內
不支持自定義 Discuz! 代碼

TOP

b9208

帖子
182 
主題
34 
精華
0 
積分
316 
點名
0  
作業系統
Win 7 
軟體版本
Office 2010 
閱讀權限
20 
性別
男 
來自
Taiwan 
註冊時間
2010-5-2 
最後登錄
2023-6-24 
8#
發表於 2011-2-1 22:50 | 只看該作者
回復 6# Hsieh

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

B2-1.rar (14.83 KB)
100 字節以內
不支持自定義 Discuz! 代碼

TOP

Hsieh

帖子
4901 
主題
44 
精華
24 
積分
4916 
點名
91  
作業系統
Windows 7 
軟體版本
Office 20xx 
閱讀權限
150 
性別
男 
來自
台北 
註冊時間
2010-4-30 
最後登錄
2024-4-20 

2023年全勤獎章2022虎年全勤獎章2021牛年全勤獎章2020鼠年全勤獎章2019 豬年全勤獎章2018 狗年全勤獎章2017 雞年全勤獎章2016猴年全勤獎章2015羊年全勤獎章2014馬年全勤獎章2013蛇年全勤獎章2012龍年全勤獎章論壇貢獻勳章熱心公益勳章2011兔年全勤獎章
9#
發表於 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
複製代碼
學海無涯_不恥下問

TOP

b9208

帖子
182 
主題
34 
精華
0 
積分
316 
點名
0  
作業系統
Win 7 
軟體版本
Office 2010 
閱讀權限
20 
性別
男 
來自
Taiwan 
註冊時間
2010-5-2 
最後登錄
2023-6-24 
10#
發表於 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]欄位之資料都是被格式化成文字的數字，
在排序選項中〞將任何看似數字的項目視為數字來排列〞此選項可以完成。
請教要如何修改程式碼。

非常感謝
100 字節以內
不支持自定義 Discuz! 代碼

TOP

        靜思自在 : 改變自己是自救，影響別人是救人。
12
返回列表 上一主題