龍龍
Lv 4
龍龍 asked in 電腦與網際網路軟體 · 10 years ago

VBA~複製前1期和當期及下n期的資料。

附檔網址︰http://www.funp.net/856933

MS2003版

因為覺得前題用函數陣列公式運算太緩慢了,所以希望能改以VBA語法來達成需求~

在I1填入n值(EX︰2),然後在InputBox鍵入期數(EX︰48~49)後~

則會自動將DATA有顯示=mthcount期數列的B︰H數值~

其前1期和當期及下n期的期數和開獎號碼並加上DATA 的A2︰H2之標題~

以橫式列出而產生各期之效果檔案(各有7個工作表)。

且各工作表的J︰P有顯示=mthcount期數列的B︰H數值之儲存格會自動標示黃顏色。

檔案名稱則為︰TEST_mthcount期_下I1期

EX︰TEST_48期_下2期和TEST_49期_下2期

請問上述需求的VBA程式碼要如何編寫? 謝謝!

Update:

謝謝您如此快速的回覆我的請託~幫我解難! ^ ^

http://www.funp.net/936584

有將貴程式碼原文貼上,產生的效果檔案沒有問題~

只是VBA檔案的[E1]之起迄期數沒辦法顯示出來~

但我看列46已有startrang & "~" & endrang

所以看了老半天,也不知哪裡有問題?^^"

另外想請大大將~當有同名檔案的【是否取代】的提示窗消除~

以新檔案直接覆蓋舊檔案即可!

以上 有勞大大再次賜教!

謝謝您!

2 Answers

Rating
  • loow77
    Lv 5
    10 years ago
    Favorite Answer

    Sub TS() Dim CHrang(2), tim!

    Dim Newsheet, Nowpath, Mthcount

    CHrang(1) = InputBox("Form", "輸入期數") + 3

    CHrang(2) = InputBox("To", "輸入期數") + 3

    NEXTCH = [I1]

    tim = Timer

    Nowpath = ActiveWorkbook.Path

    Application.ScreenUpdating = False

    On Error Resume Next

    For Mthcount = CHrang(1) To CHrang(2)

    For K = 1 To 7

    NB = 0

    Set Newsheet = Sheets.Add(, Worksheets(Worksheets.Count))

    Newsheet.Name = "Sheet" & K

    Sheets("DATA").Activate

    For CH = 0 To [I1] + 1

    Range("A2:H2").Copy Destination:=Sheets("Sheet" & K).Cells(1, CH * 8 + 1) ''標題

    Next CH

    For Y = 3 To Range("A65536").End(3)

    For X = 1 To 7

    If Cells(Y, 1 + X) = Cells(Mthcount, K + 1) Then

    NB = NB + 1

    If Cells(Y - 1, 2) > 0 Then Range("A" & Y - 1 & ":" & "H" & Y - 1).Copy Destination:=Sheets("Sheet" & K).Cells(NB + 1, 1) ''上期

    If Cells(Y, 2) > 0 Then Range("A" & Y & ":" & "H" & Y).Copy Destination:=Sheets("Sheet" & K).Cells(NB + 1, 9) ''當期

    For NC = 1 To [I1]

    If Cells(Y + NC, 2) > 0 Then Range("A" & Y + NC & ":" & "H" & Y + NC).Copy Destination:=Sheets("Sheet" & K).Cells(NB + 1, 9 + NC * 8) ''下一期

    Next NC

    Exit For

    End If

    Next X

    Next Y

    Sheets("Sheet" & K).Range("J:P").FormatConditions.Add Type:=xlCellValue, Operator:=xlEqual, _

    Formula1:=Cells(Mthcount, K + 1)

    Sheets("Sheet" & K).Range("J:P").FormatConditions(1).Interior.ColorIndex = 6

    Next K

    Sheets(Array("Sheet1", "Sheet2", "Sheet3", "Sheet4", "Sheet5", "Sheet6", "Sheet7")).Move

    ActiveWorkbook.SaveAs Filename:=Nowpath & "\TEST_" & Mthcount - 3 & "期_下" & NEXTCH & "期.xls"

    ActiveWorkbook.Close

    Next Mthcount

    [I1].Select

    [E1] = startrang & "~" & endrang & "=" & Format((Timer - tim) / 24 / 60 / 60, "hh:mm:ss")

    MsgBox "完成"

    End Sub

    2011-01-06 08:35:56 補充:

    修正48列

    E1] = CHrang(1) - 3 & "~" & CHrang(2) - 3 & "=" & Format((Timer - tim) / 24 / 60 / 60, "hh:mm:ss")

    新增

    41列 Application.DisplayAlerts = False

    44列 Application.DisplayAlerts = True

    2011-01-06 08:37:01 補充:

    修正48列漏了一個[號

    Source(s): 知識+
  • 6 years ago

    * 九州娛樂 http://*****/

    [電子遊戲]

    拉霸、水果盤、7PK、5PK

    [運彩遊戲]

    棒球、籃球、足球、網球、冰球、各種體育經典賽事

    [真人遊戲]

    百家樂、21點、骰寶、輪盤、牌九、三公、輪盤、翻攤、牛牛、二八杠

    [對戰遊戲]

    台灣麻將、德州撲克、骰盅吹牛、四支刀、鬥地主、十三支、二八槓、暗棋、接龍

    [彩球遊戲]

    香港六合、台灣樂透、今彩539、樂合彩、大陸時時彩、基諾彩、北京賽車、賽狗、賽馬、指數

    [優惠活動]

    1. 新舊會員儲值就送500點

    2. 真人百家樂彩金等你拿

    九州娛樂 hhttp://*****/

    歡迎免費體驗試玩!!

Still have questions? Get your answers by asking now.