Lv 4

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

MS2003版

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

### 2 個解答

• loow77
Lv 5
1 0 年前
最佳解答

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

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")

新增

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

修正48列漏了一個[號

參考資料： 知識+
• 6 年前

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

[電子遊戲]

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

[運彩遊戲]

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

[真人遊戲]

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

[對戰遊戲]

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

[彩球遊戲]

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

[優惠活動]

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

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

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

歡迎免費體驗試玩!!