[發問] 在每列第1欄輸入筆數, 依筆數覆製每列訊息後另存成一個新檔

帖子: 5923
主題: 13
精華: 1
積分: 5986
點名: 0
作業系統: win10
軟體版本: Office 2010
閱讀權限: 150
性別: 男
來自: 台灣基隆
註冊時間: 2010-5-1
最後登錄: 2022-1-23

2017 雞年全勤獎章 2016猴年全勤獎章 2015羊年全勤獎章 2014馬年全勤獎章 2013蛇年全勤獎章 2012龍年全勤獎章論壇貢獻勳章熱烈參與勳章 2011兔年全勤獎章

2^#

發表於 2011-5-10 21:53 | 只看該作者

回復 1# melvinhsu1105
同樣的問題覆製後???
http://forum.twbts.com/redirect.php?goto=findpost&pid=19728&ptid=3503 3

帖子: 15
主題: 5
精華: 0
積分: 20
點名: 0
作業系統: WINDOWS
軟體版本: XP
閱讀權限: 10
性別: 男
註冊時間: 2011-4-26
最後登錄: 2011-5-13

3^#

發表於 2011-5-10 23:58 | 只看該作者

先進，不是同樣問題，𣎴好意思。

另，所覆製之格式，除在原資料表第一欄外，其餘皆依選取的列資料依筆數全數（未鍵入筆數的列資料，不覆製）在新的工作表的第一列，第一欄依序貼上。

如有不清楚之處，再指教

GBKEE

帖子: 5923
主題: 13
精華: 1
積分: 5986
點名: 0
作業系統: win10
軟體版本: Office 2010
閱讀權限: 150
性別: 男
來自: 台灣基隆
註冊時間: 2010-5-1
最後登錄: 2022-1-23

2017 雞年全勤獎章 2016猴年全勤獎章 2015羊年全勤獎章 2014馬年全勤獎章 2013蛇年全勤獎章 2012龍年全勤獎章論壇貢獻勳章熱烈參與勳章 2011兔年全勤獎章

4^#

發表於 2011-5-11 08:51 | 只看該作者

回復 3# melvinhsu1105
是這樣媽?

Option Explicit
Sub Ex()
Dim AR(), C%, i%, ii%
ReDim AR(0) 'ReDim:重新配置動態陣列變數的儲存空間 ->0到0
With ActiveSheet
C = .[B1].End(xlToRight).Column '取的:B1往右連續資料表頭最後的欄位數
AR(0) = .Range("B1", .Cells(1, C)).Value '指定:陣列的元素值
For i = 2 To .Cells(2, "A").End(xlDown).Row '迴圈:從A2開始往下直到沒資料的列位
For ii = 1 To .Cells(i, "A").Value '迴圈:從1開始到.Cells(i, "A").Value =複製的筆數
ReDim Preserve AR(UBound(AR) + 1) 'ReDim:重新配置動態陣列變數的儲存空間->原有維數+1
'Preserve:當改變原有陣列最後一維的大小時，仍然保有原來的資料的關鍵字。
'UBound:表示指定陣列某維最大可使用的陣列索引
AR(UBound(AR)) = .Range(.Cells(i, "B"), .Cells(i, C)).Value '指定:陣列最大的元素值
Next
Next
End With
With Workbooks.Add.Sheets(1).Range("A1") 'With: 在一個單一物件或一個使用者自訂型態上執行一系列的陳述式。
For i = 0 To UBound(AR) '迴圈:從AR的第1個元素(0)到AR的最大元素UBound(AR)
.Offset(i).Resize(, C - 1) = AR(i) '.Offset(i):在此i表往下的列數
'.Resize(, C - 1): 擴充的範圍為(1列,C - 1欄)=陣列元素的值
Next
End With
End Sub

複製代碼

帖子: 15
主題: 5
精華: 0
積分: 20
點名: 0
作業系統: WINDOWS
軟體版本: XP
閱讀權限: 10
性別: 男
註冊時間: 2011-4-26
最後登錄: 2011-5-13

5^#

發表於 2011-5-11 09:57 | 只看該作者

回復 4# GBKEE

板主, 感謝您一直耐心回覆, 而剛利用你回覆的碼套用, 似乎無法執行. 但也沒有程式偵錯的訊息.

GBKEE

帖子: 5923
主題: 13
精華: 1
積分: 5986
點名: 0
作業系統: win10
軟體版本: Office 2010
閱讀權限: 150
性別: 男
來自: 台灣基隆
註冊時間: 2010-5-1
最後登錄: 2022-1-23

2017 雞年全勤獎章 2016猴年全勤獎章 2015羊年全勤獎章 2014馬年全勤獎章 2013蛇年全勤獎章 2012龍年全勤獎章論壇貢獻勳章熱烈參與勳章 2011兔年全勤獎章

6^#

發表於 2011-5-11 10:18 | 只看該作者

剛利用你回覆的碼套用, 似乎無法執行. 但也沒有程式偵錯的 ...
melvinhsu1105 發表於 2011/5/11 09:57

我也不知道? 沒看到你的檔案不知你如何套用 [同樣的問題]

PS: 2樓同樣的問題 ->你沒將你確切想法說詳細用範例來表達.

帖子: 15
主題: 5
精華: 0
積分: 20
點名: 0
作業系統: WINDOWS
軟體版本: XP
閱讀權限: 10
性別: 男
註冊時間: 2011-4-26
最後登錄: 2011-5-13

7^#

發表於 2011-5-11 13:47 | 只看該作者

再補上想完成的範列圖, 再請板主幫忙. 不好意思了.

Hsieh

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

2024年全勤獎章 2023年全勤獎章 2022虎年全勤獎章 2021牛年全勤獎章 2020鼠年全勤獎章 2019 豬年全勤獎章 2018 狗年全勤獎章 2017 雞年全勤獎章 2016猴年全勤獎章 2015羊年全勤獎章 2014馬年全勤獎章 2013蛇年全勤獎章 2012龍年全勤獎章論壇貢獻勳章熱心公益勳章 2011兔年全勤獎章

8^#

發表於 2011-5-11 14:17 | 只看該作者

回復 7# melvinhsu1105

Sub ex()
Dim Ar()
With ActiveSheet
a = .Range("A1").CurrentRegion
ReDim Preserve Ar(s)
Ar(s) = Application.Index(a, 1)
s = s + 1
For i = 2 To UBound(a, 1)
For j = 1 To a(i, 1)
ReDim Preserve Ar(s)
Ar(s) = Application.Index(a, i)
s = s + 1
Next
Next
End With
With Workbooks.Add
.Sheets(1).[A1].Resize(s, UBound(a, 2)) = Application.Transpose(Application.Transpose(Ar))
.Sheets(1).Columns("A").Delete
'.SaveAs "D:\Test.xls" '新檔存檔目錄自行修改
End With
End Sub

複製代碼

學海無涯_不恥下問

帖子: 15
主題: 5
精華: 0
積分: 20
點名: 0
作業系統: WINDOWS
軟體版本: XP
閱讀權限: 10
性別: 男
註冊時間: 2011-4-26
最後登錄: 2011-5-13

9^#

發表於 2011-5-12 00:22 | 只看該作者

回復 8# Hsieh

老師, 謝謝你的回應.

而小弟我在直接覆製上後, 執行, 未有任何作用, 原因為何, ? 已在補上照.

多有勞煩.

luhpro

高中生 Rank: 3 Rank: 3

帖子: 835
主題: 6
精華: 0
積分: 915
點名: 1
作業系統: Win 10,7
軟體版本: 2019,2013,2003
閱讀權限: 50
性別: 男
註冊時間: 2010-5-3
最後登錄: 2025-7-5

10^#

發表於 2011-5-12 00:48 | 只看該作者

本帖最後由 luhpro 於 2011-5-12 00:49 編輯

回復 9# melvinhsu1105

可能是你程式碼放錯地方了.
Sub ex() 與最底下的 End Sub 都不要 Copy,
只 Copy 中間的程式碼就好,
然後點兩下 CommandButton1 它會自動建立 :

Private Sub CommandButton1_Click()

End Sub

把 Copy 的程式碼放在上述兩行 Sub 敘述的中間即可.