Board logo

標題: [發問] 在每列第1欄輸入筆數, 依筆數覆製每列訊息後另存成一個新檔 [打印本頁]
作者: melvinhsu1105    時間: 2011-5-10 21:43     標題: 在每列第1欄輸入筆數, 依筆數覆製每列訊息後另存成一個新檔

本帖最後由 melvinhsu1105 於 2011-5-12 00:20 編輯

再請問, 各位先進及老師,

小弟, 希望在一資料表內的第1欄, 輸入需覆製的筆數, 而後在執行巨集, 依每列第1欄的筆數,覆製後, 再另存(開)一新檔, 不知應如何製作.
[attach]6111[/attach]
[attach]6121[/attach]
[attach]6122[/attach]
[attach]6132[/attach]
作者: GBKEE    時間: 2011-5-10 21:53

回復 1# melvinhsu1105
同樣的問題  覆製後???
http://forum.twbts.com/redirect.php?goto=findpost&pid=19728&ptid=3503 3
作者: melvinhsu1105    時間: 2011-5-10 23:58

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

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

如有不清楚之處，再指教
作者: GBKEE    時間: 2011-5-11 08:51

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

回復 4# GBKEE


板主, 感謝您一直耐心回覆, 而 剛利用你回覆的碼套用, 似乎無法執行. 但也沒有程式偵錯的訊息.
作者: GBKEE    時間: 2011-5-11 10:18

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

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

PS:   2樓  同樣的問題 ->你沒將你確切想法說詳細 用範例來表達.
作者: melvinhsu1105    時間: 2011-5-11 13:47

再補上想完成的範列圖, 再請板主幫忙. 不好意思了.
作者: Hsieh    時間: 2011-5-11 14:17

回復 7# melvinhsu1105
  1. Sub ex()
  2. Dim Ar()
  3. With ActiveSheet
  4. a = .Range("A1").CurrentRegion
  5. ReDim Preserve Ar(s)
  6. Ar(s) = Application.Index(a, 1)
  7. s = s + 1
  8. For i = 2 To UBound(a, 1)
  9.    For j = 1 To a(i, 1)
  10.       ReDim Preserve Ar(s)
  11.       Ar(s) = Application.Index(a, i)
  12.       s = s + 1
  13.    Next
  14. Next
  15. End With
  16. With Workbooks.Add
  17.   .Sheets(1).[A1].Resize(s, UBound(a, 2)) = Application.Transpose(Application.Transpose(Ar))
  18.   .Sheets(1).Columns("A").Delete
  19.   '.SaveAs "D:\Test.xls" '新檔存檔目錄自行修改
  20. End With
  21.   
  22. End Sub
複製代碼
作者: melvinhsu1105    時間: 2011-5-12 00:22

回復 8# Hsieh


    老師, 謝謝你的回應.

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

多有勞煩.
作者: luhpro    時間: 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 敘述的中間即可.
作者: Hsieh    時間: 2011-5-12 07:22

回復 9# melvinhsu1105


    上傳你作的檔案看看
作者: melvinhsu1105    時間: 2011-5-12 11:15

本帖最後由 GBKEE 於 2011-5-12 11:44 編輯

回復 10# luhpro


的確.是醬子的. 我昨天沒用好. 感謝. 先進.

回復 11# Hsieh


    老師, 抱歉我昨天沒用好, 故未能成功. 再次謝謝您的協助.



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