[發問] 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

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

樓主熱帖

Airman

中學生 Rank: 2

帖子: 315
主題: 51
精華: 0
積分: 367
點名: 0
作業系統: win7
軟體版本: office2003
閱讀權限: 20
性別: 男
註冊時間: 2015-9-29
最後登錄: 2021-10-12

2^#

發表於 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:
紅色字碼修正後，小弟測試後~再向您報告結果~如哪邊還是有問題再修~
這樣一步步來，可能比較不會太勞煩您

TOP

Airman

中學生 Rank: 2

帖子: 315
主題: 51
精華: 0
積分: 367
點名: 0
作業系統: win7
軟體版本: office2003
閱讀權限: 20
性別: 男
註冊時間: 2015-9-29
最後登錄: 2021-10-12

3^#

發表於 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# 紅色字碼的正確語法~
感恩

TOP

Airman

中學生 Rank: 2

帖子: 315
主題: 51
精華: 0
積分: 367
點名: 0
作業系統: win7
軟體版本: office2003
閱讀權限: 20
性別: 男
註冊時間: 2015-9-29
最後登錄: 2021-10-12

4^#

發表於 2016-1-16 12:24 | 顯示全部帖子

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

這下小弟實在沒輒了

TOP