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

melvinhsu1105

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

小弟, 希望在一資料表內的第1欄, 輸入需覆製的筆數, 而後在執行巨集, 依每列第1欄的筆數,覆製後, 再另存(開)一新檔, 不知應如何製作.

下載 (84.75 KB)

2011-5-10 21:43

下載 (107.43 KB)

2011-5-11 13:45

下載 (54.86 KB)

2011-5-11 13:45

下載 (150.69 KB)

2011-5-12 00:20

GBKEE

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

melvinhsu1105

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

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

如有不清楚之處，再指教

GBKEE

回復 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

回復 4# GBKEE


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

GBKEE

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

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

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

melvinhsu1105

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

Hsieh

回復 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

回復 8# Hsieh


    老師, 謝謝你的回應.

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

多有勞煩.

luhpro

回復 9# melvinhsu1105

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

Private Sub CommandButton1_Click()

End Sub

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