麻辣家族討論版版 - Powered by Discuz! Board

標題: [發問] VBA_如何以讀取的【單欄】各產生一個工作表？ [打印本頁]

作者: Airman 時間: 2016-1-14 13:34 標題: VBA_如何以讀取的【單欄】各產生一個工作表？

本帖最後由 Airman 於 2016-1-14 13:44 編輯

參考附件︰http://www.FunP.Net/890930

列229~列249的程式碼是以讀取總表(S_49_A交集_" & NUM & "_" & mthcount & "期_ML)
T欄到IV欄第7列(含)以下<>空白的儲存格各產生一個工作表~即以有顯示數字的【儲存格】為標準~
EX︰總表的Sheet24
S_49_A交集_10_100期-24sheet-58(NOW) & S_49_A交集_10_100期-24sheet-79(NOW)

請問︰
下列的程式碼要如何改為將T欄到IV欄第7列(含)以下有<>空白的儲存格之各欄各產生一個工作表~即以有顯示數字的【單欄】為標準~
EX︰總表的Sheet24
S_49_A交集_10_100期-24sheet-58(NEW) & S_49_A交集_10_100期-24sheet-79(NEW)

'產生工作表..............................................................................    '列229
      Sa = 0
      Windows("S_49_A交集_" & NUM & "_" & mthcount & "期_ML.xls").Activate  '選取總表
      shcount = ActiveWorkbook.Sheets.Count
      For sh = 1 To shcount  '總表各工作表
      tx = Sheets(1).[R7].End(xlDown).Row 'R欄第7列以下
      ty = Sheets(1).[IV5].End(xlToLeft).Column  'IV欄第5列往左

      For tz = 20 To ty 'T欄到IV欄
      Sheets(1).Range("T7:T" & tx).Select 'T欄
      For Each b In Selection
         If b <> "" Then
            Sheets.Add  'T欄第7列(含)以下<>空白的儲存格產生工作表
            ActiveWindow.Zoom = 75 '縮放
            d = d + 1
            ReDim Preserve brr(d - 1)
            ActiveSheet.Name = Sheets(d + 1).[T5] & "-" & Sheets(d + 1).Range("R" & b.Row) '工作表重新命名
            brr(d - 1) = Sheets(d + 1).[T5] & "-" & Sheets(d + 1).Range("R" & b.Row) '工作表重新命名記錄陣列
            'ActiveSheet.Name = Sheets(d + 1).[T5] & "-" & Sheets(d + 1).[T3] '工作表重新命名
            'brr(d - 1) = Sheets(d + 1).[T5] & "-" & Sheets(d + 1).[T3] '工作表重新命名記錄陣列
'I:T...............................................................................................................    '列249

其餘詳如附件。
以上  懇請各位先進、前輩不吝賜教!  謝謝!

作者: 准提部林 時間: 2016-1-15 13:54

只提供測試片段，執行前，先開啟〔S_49_A交集_10_100期_ML〕檔案～～
　
[attach]23118[/attach]
　
自行去套修，這樣程式湊成堆，眼睛真的吃力！！！

作者: Airman 時間: 2016-1-15 21:11

回復 2# 准提部林

准大︰
不好意思，總是勞煩您

以貴檔原文先測試~按執行鍵後即【產生陣列索引超出範圍】的提示~偵錯結果卡在列239。
不知是不是小弟的操作有誤?
敬請再次賜教!謝謝您

另~小弟有自行試修過~但不知如何表達【總表的T欄到IV欄第7列(含)以下有<>空白的儲存格之各欄】~
紅色字碼敬請賜正~感恩

'產生工作表..............................................................................    '列229
      Sa = 0
      Windows("S_49_A交集_" & NUM & "_" & mthcount & "期_ML.xls").Activate
      shcount = ActiveWorkbook.Sheets.Count
      For sh = 1 To shcount
      tx = Sheets(1).[R7].End(xlDown).Row
      ty = Sheets(1).[IV5].End(xlToLeft).Column

      For tz = 20 To ty
      Sheets(1).Range("T7:T" & tx).Select
      If Application.Count(Selection) > 0 Then
         Sheets.Add
         ActiveWindow.Zoom = 75 '縮放
         d = d + 1
         ReDim Preserve brr(d - 1)
         ActiveSheet.Name = Sheets(d + 1).[T5] & "-" & Sheets(d + 1).[T3] '工作表重新命名
         brr(d - 1) = Sheets(d + 1).[T5] & "-" & Sheets(d + 1).[T3] '工作表重新命名記錄陣列
         brr(d - 1) = ActiveSheet.Name
         Sheets(d + 1).Columns("A:T").Copy '複製A:T的資料內容
         Sheets(1).[A1].Select
         ActiveSheet.Paste
      End If
      Sheets(1).Range("T7:T" & tx).Select
      For Each b In Selection
         If b <> "" Then
'I:T...............................................................................................................

PS:
紅色字碼修正後，小弟測試後~再向您報告結果~如哪邊還是有問題再修~
這樣一步步來，可能比較不會太勞煩您

作者: 准提部林 時間: 2016-1-15 21:54

回復 3# Airman

執行前，先開啟〔S_49_A交集_10_100期_ML〕檔案　

[attach]23119[/attach]
　
其它註解掉的程式碼，表示未處理，太多了，無法一一去理解，
尤其測試時，一直重覆產生工作表的流程，太花時間！所以略去！
目前只能提供此段程式，請自行去套入及修改！

不太習慣將不同需求．不同流程的程式串在一起，對閱讀及測試相當困擾及費時，
一般都使用模組內，以區域分段寫，再運用call方式去串接各段（自己用的程式，寫在工作表事件區的少之又少）～～

視力受損至今未回復，只能勉強為之，恐無法提供全面完整的程式碼！！！

作者: Airman 時間: 2016-1-15 22:45

本帖最後由 Airman 於 2016-1-15 22:57 編輯

回復 4# 准提部林

准大︰
不好意思，測試結果~貴解答檔產生得效果檔及其內的工作表和原提問主檔產生的一模一樣~
即與S_49_A交集_10_100期-24sheet-58(NOW) & S_49_A交集_10_100期-24sheet-79(NOW)完全相同。

小弟的需求是效果檔中的工作表要如S_49_A交集_10_100期-24sheet-58(NEW) & S_49_A交集_10_100期-24sheet-79(NEW)一般~
另~
工作表名稱請改為︰
            ActiveSheet.Name = Sheets(d + 1).[T5] & "-" & Sheets(d + 1).[T3]  '工作表重新命名
            brr(d - 1) = Sheets(d + 1).[T5] & "-" & Sheets(d + 1) .[T3] '工作表重新命名記錄陣列
以上  懇請惠予賜教!謝謝您

如果真的是太麻煩~
可否先請您賜教︰
表達【總表的T欄到IV欄第7列(含)以下有<>空白的儲存格之各欄】的範圍之語法~
即前述3# 紅色字碼的正確語法~
感恩

作者: 准提部林 時間: 2016-1-16 09:53

回復 5# Airman

Sheets(1).Range("T7:T" & tx).Select

試試＝＞　Sheets(1).Cells(7, tz).Resize(tx - 6).Select　　

〔NOW〕〔NEW〕不是對比，很難判斷哪個為新需求？

白白花了半天時間！哈～～

作者: Airman 時間: 2016-1-16 12:24

回復 6# 准提部林
准大:
呵~呵~看來我也誤解A知識長的程式碼~
小弟原以為只要將T欄範圍的程式碼~Sheets(1).Range("T7:T" & tx).Select
改為:
總表各單欄的範圍~ Sheets(1).Cells(7, tz).Resize(tx - 6).Select
應該就可以了~
但跑出來的結果完全不對

這下小弟實在沒輒了

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