返回列表 上一主題 發帖

[發問] VBA_如何以讀取的【單欄】各產生一個工作表？

Airman

帖子
315 
主題
51 
精華
0 
積分
367 
點名
0  
作業系統
win7 
軟體版本
office2003 
閱讀權限
20 
性別
男 
註冊時間
2015-9-29 
最後登錄
2021-10-12 
1# 跳轉到 » 倒序看帖
打印
tT
發表於 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

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

准提部林

帖子
2843 
主題
10 
精華
0 
積分
2899 
點名
0  
作業系統
〔略〕 
軟體版本
〔略〕 
閱讀權限
100 
性別
男 
來自
〔略〕 
註冊時間
2013-5-13 
最後登錄
2025-10-18 
2#
發表於 2016-1-15 13:54 | 只看該作者
只提供測試片段，執行前，先開啟〔S_49_A交集_10_100期_ML〕檔案∼∼
　
S_49_A交集(MF)-Q_v01.rar (64.3 KB)
　
自行去套修，這樣程式湊成堆，眼睛真的吃力！！！

TOP

Airman

帖子
315 
主題
51 
精華
0 
積分
367 
點名
0  
作業系統
win7 
軟體版本
office2003 
閱讀權限
20 
性別
男 
註冊時間
2015-9-29 
最後登錄
2021-10-12 
3#
發表於 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

准提部林

帖子
2843 
主題
10 
精華
0 
積分
2899 
點名
0  
作業系統
〔略〕 
軟體版本
〔略〕 
閱讀權限
100 
性別
男 
來自
〔略〕 
註冊時間
2013-5-13 
最後登錄
2025-10-18 
4#
發表於 2016-1-15 21:54 | 只看該作者
回復 3# Airman


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

新資料夾.rar (92.21 KB)
　
其它註解掉的程式碼，表示未處理，太多了，無法一一去理解，
尤其測試時，一直重覆產生工作表的流程，太花時間！所以略去！
目前只能提供此段程式，請自行去套入及修改！

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

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

TOP

Airman

帖子
315 
主題
51 
精華
0 
積分
367 
點名
0  
作業系統
win7 
軟體版本
office2003 
閱讀權限
20 
性別
男 
註冊時間
2015-9-29 
最後登錄
2021-10-12 
5#
發表於 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

准提部林

帖子
2843 
主題
10 
精華
0 
積分
2899 
點名
0  
作業系統
〔略〕 
軟體版本
〔略〕 
閱讀權限
100 
性別
男 
來自
〔略〕 
註冊時間
2013-5-13 
最後登錄
2025-10-18 
6#
發表於 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〕不是對比，很難判斷哪個為新需求？

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

TOP

Airman

帖子
315 
主題
51 
精華
0 
積分
367 
點名
0  
作業系統
win7 
軟體版本
office2003 
閱讀權限
20 
性別
男 
註冊時間
2015-9-29 
最後登錄
2021-10-12 
7#
發表於 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

        靜思自在 : 人要自愛，才能愛普天下的人。
返回列表 上一主題