Board logo

標題: [發問] 以控制項Nrange填入的起迄期數產生效果檔案。 [打印本頁]
作者: papaya    時間: 2019-3-3 15:34     標題: 以控制項Nrange填入的起迄期數產生效果檔案。

本帖最後由 papaya 於 2019-3-3 15:38 編輯

PS︰問題有類似(重複)~請移除前題。
謝謝!

附件︰
[attach]30159[/attach]
想將BASE(提問主檔)的程式碼，改為如下列的2個需求~
需求1︰設立Nrange控制項，以利產生效果檔案~
當控制項內填入1000，則產生名稱="排序1000"的1個效果檔案；
效果檔案內有名稱="總表"和名稱="排序1000"等2個工作表

當控制項內填入1010-1020，則產生名稱="排序1010-1020"的1個效果檔案；
效果檔案內有名稱="總表"和名稱="排序1010"，"排序1011"，.....，"排序1019"，"排序1020"等12個工作表。

當控制項內填入1000,1010-1020，則產生名稱="排序1000"和名稱="排序1010-1020"的2個效果檔案；
2個效果檔案內的工作表同上。

其餘以此類推。

當有名稱相同的效果檔案產生，則新產生的效果檔案覆蓋前已產生的效果檔案。

需求2︰各效果工作表的內容~
工作表名稱="總表"的內容=複製BASE(提問主檔)的DATA!A︰J貼上"總表"!A1。
凍結視窗"B2"

效果檔案內除了名稱="總表"以外的其他各效果工作表的內容~
A1填入= Nrange控制項內各組合數字(以逗點分隔)並標示金色圖樣
凍結視窗"B2"

請詳見附件︰排序1000(效果檔)；排序1010-1020(效果檔)

請問︰
BASE(提問主檔)的VBA程式碼要如何重新編寫？
請各位大大幫忙!謝謝各位!
作者: papaya    時間: 2019-3-3 20:47

抱歉!附件的"排序1100-1020"(效果檔)，名稱有筆誤，正確名稱應為"排序1010-1020"(效果檔)。
謝謝!
作者: stillfish00    時間: 2019-3-8 17:46

回復 2# papaya
  1. Private Sub CommandButton1_Click()
  2.     Dim text As String, istart As Integer, iend As Integer
  3.     Dim file As String, ar
  4.     text = InputBox("請輸入期數, (如: 1000,1010-1020)", "產生排序檔")
  5.     If Len(text) = 0 Then MsgBox "Bad Input": Exit Sub
  6.     Application.DisplayAlerts = False
  7.     Application.ScreenUpdating = False
  8.     For Each s In Split(text, ",")
  9.         file = ThisWorkbook.Path & "\排序" & Trim(s) & ".xls"
  10.         ar = Split(Trim(s), "-")
  11.         istart = CInt(ar(0))
  12.         If UBound(ar) = 0 Then
  13.             iend = istart
  14.         Else
  15.             iend = CInt(ar(1))
  16.         End If
  17.         
  18.         If Len(Dir(file)) > 0 Then Kill file
  19.         Set wb = Workbooks.Add()
  20.         With wb
  21.             For i = .Sheets.Count To 2 Step -1: .Sheets(i).Delete: Next
  22.             With .Sheets(1)
  23.                 .Name = "總表"
  24.                 ThisWorkbook.Sheets("DATA").[A:J].Copy .[A1]
  25.                 .Activate
  26.                 .[B2].Select
  27.                 ActiveWindow.FreezePanes = True
  28.             End With
  29.             .Sheets.Add After:=.Sheets(1), Count:=iend - istart + 1
  30.             For i = 0 To iend - istart
  31.                 With .Sheets(i + 2)
  32.                     .Name = "排序" & istart + i
  33.                     .[A1].Value = istart + i
  34.                     .[A1].Font.Bold = True
  35.                     .[A1].Interior.Color = 52479
  36.                     .Activate
  37.                     .[B2].Select
  38.                     ActiveWindow.FreezePanes = True
  39.                 End With
  40.             Next
  41.             .Sheets(1).Activate
  42.             .SaveAs Filename:=file, FileFormat:=xlWorkbookNormal
  43.             .Close False
  44.         End With
  45.     Next
  46.     Application.ScreenUpdating = True
  47.     Application.DisplayAlerts = True
  48.     MsgBox "Finish"
  49. End Sub
複製代碼
作者: papaya    時間: 2019-3-8 22:53

回復 3# stillfish00

感謝您的幫忙和指導



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