- 帖子
- 88
- 主題
- 13
- 精華
- 0
- 積分
- 104
- 點名
- 0
- 作業系統
- WIN7
- 軟體版本
- OFFICE2010
- 閱讀權限
- 20
- 性別
- 男
- 註冊時間
- 2012-1-3
- 最後登錄
- 2017-12-31
|
7#
發表於 2012-2-26 22:18
| 只看該作者
本帖最後由 yagami12th 於 2012-2-26 22:27 編輯
回復 4# Hsieh
用loop的檔案改成功了，原來是有些指定名稱不用用"" 包起來
如附件：
 4finish.rar (818.72 KB)
Option Explicit
Dim Flag
Dim myRow As Integer
Dim newSheet As String
Sub addsheetVer2()
Static Num As Integer
Sheets.Add after:=Sheets(Sheets.Count) '指名引數，數該excel檔有幾個sheet放在最右邊
Sheets(Sheets.Count).Select
newSheet = "pick" & Num
ActiveSheet.Name = newSheet
Num = Num + 1
End Sub
Sub ChooseVer2(rowChoose, sheetName As String) '原先只有輸入列號，現在要加上工作表的名字
If Worksheets(sheetName).Cells(rowChoose, 5).Value > 10 Then
Flag = 1 '只選取指定sheet的資料做篩選
End If
End Sub
Sub CopyPasteVer2(rowCopy, rowPaste, copySheet As String, pasteSheet As String) 'copy the row rowcopy in sheet with name "2330"
Dim myStr As String 'and paste to the row rowpaste in the sheet "pick"
Sheets(copySheet).Select
myStr = rowCopy & ":" & rowCopy
Rows(myStr).Select
Selection.Copy
Sheets(pasteSheet).Select
myStr = "A" & rowPaste
Range(myStr).Select
ActiveSheet.Paste
End Sub
Sub main3()
Dim i As Integer
Dim myRange As Range
Dim myCell
Dim mySheet As String
mySheet = InputBox("input the sheet name you analyze") '選擇工作表
Set myRange = Application.InputBox("Choose the days", Type:=8) '幫我選取我要篩選的範圍
addsheetVer2 '執行上述新增工作表的程式，每次增加的不一樣，可以執行上面寫的好幾個副程式，可以讓每個程式分工合作，組合在一起
myRow = 1
For Each myCell In myRange '在我的myrange裡對每一個mycell，來做下面的事情
i = myCell.Row
Flag = 0 '不符合我的要求就跳到下一圈去看是否有符合
ChooseVer2 i, mySheet '檢測第20行是否符合我設的條件
If Flag = 1 Then
CopyPasteVer2 i, myRow, mySheet, newSheet '符合設定條件，貼到新的工作表，因為不是只有第二十行，所以要寫迴圈
myRow = myRow + 1
End If
Next
End Sub
Sub main4()
Dim i As Integer
Dim mySheet As String
mySheet = InputBox("input the sheet name you analyze") '選擇工作表
addsheetVer2 '執行上述新增工作表的程式，每次增加的不一樣，可以執行上面寫的好幾個副程式，可以讓每個程式分工合作，組合在一起
myRow = 1: i = 2
Do While Worksheets(mySheet).Cells(i, 1) <> "" '在指定的工作表裡第一行往下掃只要不是空白格就執行下面的程式碼
Flag = 0 '不符合我的要求就跳到下一圈去看是否有符合
ChooseVer2 i, mySheet '檢測是否符合我設的條件
If Flag = 1 Then
CopyPasteVer2 i, myRow, mySheet, newSheet '符合設定條件，貼到新的工作表，因為不是只有第二十行，所以要寫迴圈
myRow = myRow + 1
End If
i = i + 1
Loop
End Sub |
|
發表於 2012-2-27 13:28
| 
