返回列表 上一主題 發帖

[發問] 關於"在原資料表截取特定資料貼到新sheet的問題"

yagami12th

帖子
88 
主題
13 
精華
0 
積分
104 
點名
0  
作業系統
WIN7 
軟體版本
OFFICE2010 
閱讀權限
20 
性別
男 
註冊時間
2012-1-3 
最後登錄
2017-12-31 
1# 跳轉到 » 倒序看帖
打印
tT
發表於 2012-2-26 17:17 | 顯示全部帖子

[發問] 關於"在原資料表截取特定資料貼到新sheet的問題"

因為寫的程式無法順利成功篩選後複製，都是變成空白，所以想請教大家。

附檔： test.rar (818.44 KB)

資料說明：
附檔內excel裡的sheet1是聯電股價原始資料，主要目的是要篩選出"股價大於10"的資料將其複製到新增後的"pick"sheet

自已嘗試著做出來的程式碼如下：

Option Explicit
Dim Flag
Dim myRow As Integer
--------------------------------
Sub addsheet()
   
    Sheets.Add
    Sheets(1).Select
    ActiveSheet.Name = "pick"
End Sub
---------------------------------
Sub Choose(k)
If Worksheets("Sheet1").Cells(k, 5).Value > 10 Then
    Flag = 1
ElseIf Worksheets("Sheet1").Cells(k, 5).Value > 5 And Worksheets("Sheet1").Cells(k, 5).Value <= 10 Then
    Flag = 0
End If
End Sub
----------------------------------
Sub CopyPaste(L, M)
Dim myStr As String

    myStr = L & ":" & L
    Rows("20:20").Select
    Selection.Copy
    Sheets("pick").Select
'    myStr = a & ":" & "M"
    Range(myStr).Select
    ActiveSheet.Paste
End Sub
---------------------------------
Sub main2()
Dim i As Integer
Dim myRange As Range
Dim myCell

Set myRange = Application.InputBox("Choose the days", Type:=8) '幫我選取我要的東西

addsheet '執行上述新增工作表的程式，可以執行上面寫的好幾個副程式，可以讓每個程式分工合作，組合在一起
myRow = 1

For Each myCell In myRange '在我的myrange裡對每一個mycell，來做下面的事情
    i = myCell.Row
        
    Flag = 0 '不符合我的要求就跳到下一圈去看是否有符合
    Choose i '檢測第20行是否符合我設的條件
    If Flag = 1 Then
        CopyPaste i, myRow '符合設定條件，貼到新的工作表，因為不是只有第二十行，所以要寫迴圈
        myRow = myRow + 1
    End If
Next
End Sub
收藏 分享

yagami12th

帖子
88 
主題
13 
精華
0 
積分
104 
點名
0  
作業系統
WIN7 
軟體版本
OFFICE2010 
閱讀權限
20 
性別
男 
註冊時間
2012-1-3 
最後登錄
2017-12-31 
2#
發表於 2012-2-26 20:07 | 顯示全部帖子
回復 2# Hsieh

謝謝版大，我好像用出來了，但有一行一直除不了錯，如下綠字色體：
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
    ActiveSheet.Name = "pick & num"
   
    Num = Num + 1
End Sub


Sub ChooseVer2(rowChoose, sheetName As String) '原先只有輸入列號，現在要加上工作表的名字


If Worksheets("sheetName").Cells(rowChoose, 5).Value > 10 Then
    Flag = 1 '只選取指定sheet的資料做篩選
Else
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("pastSheet").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

TOP

yagami12th

帖子
88 
主題
13 
精華
0 
積分
104 
點名
0  
作業系統
WIN7 
軟體版本
OFFICE2010 
閱讀權限
20 
性別
男 
註冊時間
2012-1-3 
最後登錄
2017-12-31 
3#
發表於 2012-2-26 20:21 | 顯示全部帖子
回復 4# Hsieh

一直停在這行除錯，無法執行，程式碼應該沒錯才對．．．

    If Worksheets(sheetName).Cells(rowChoose, 5).Value > 10 Then
     Flag = 1 '只選取指定sheet的資料做篩選
Else
End If
End Sub

TOP

yagami12th

帖子
88 
主題
13 
精華
0 
積分
104 
點名
0  
作業系統
WIN7 
軟體版本
OFFICE2010 
閱讀權限
20 
性別
男 
註冊時間
2012-1-3 
最後登錄
2017-12-31 
4#
發表於 2012-2-26 20:42 | 顯示全部帖子
回復 4# Hsieh
回版大，改成用loop迴圈同樣也出現錯誤，試不出原因，除錯視窗停在下面綠色字體的地方

如附件： 4最後.rar (818.3 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的資料做篩選
Else: the Flag = 0

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("pastSheet").Select
    myStr = "A" & rowPaste
    Range(myStr).Select
    ActiveSheet.Paste

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

TOP

yagami12th

帖子
88 
主題
13 
精華
0 
積分
104 
點名
0  
作業系統
WIN7 
軟體版本
OFFICE2010 
閱讀權限
20 
性別
男 
註冊時間
2012-1-3 
最後登錄
2017-12-31 
5#
發表於 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

TOP

yagami12th

帖子
88 
主題
13 
精華
0 
積分
104 
點名
0  
作業系統
WIN7 
軟體版本
OFFICE2010 
閱讀權限
20 
性別
男 
註冊時間
2012-1-3 
最後登錄
2017-12-31 
6#
發表於 2012-2-26 22:49 | 顯示全部帖子
回復 2# Hsieh
謝謝版大的程式碼，我的檔案如附件，有錯誤的程式碼為下面綠色字體： 3未成品.rar (819.19 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
    ActiveSheet.Name = "pick & num"
   
    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        <<<<<<<這裡出現陣列索引錯誤9，把冒號的錯誤更正還是一樣~~
    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 '
    If Flag = 1 Then
        CopyPasteVer2 i, myRow, mySheet, newSheet '在指定的工作表作篩選後貼過去，符合設定條件，貼到新的工作表，因為不是只有第二十行，所以要寫迴圈
        myRow = myRow + 1
    End If
   
Next
End Sub

TOP

yagami12th

帖子
88 
主題
13 
精華
0 
積分
104 
點名
0  
作業系統
WIN7 
軟體版本
OFFICE2010 
閱讀權限
20 
性別
男 
註冊時間
2012-1-3 
最後登錄
2017-12-31 
7#
發表於 2012-2-27 09:20 | 顯示全部帖子
回復 10# GBKEE

謝謝GBKEE大:D ，我再試試看。

TOP

yagami12th

帖子
88 
主題
13 
精華
0 
積分
104 
點名
0  
作業系統
WIN7 
軟體版本
OFFICE2010 
閱讀權限
20 
性別
男 
註冊時間
2012-1-3 
最後登錄
2017-12-31 
8#
發表於 2012-2-27 12:04 | 顯示全部帖子
本帖最後由 yagami12th 於 2012-2-27 12:07 編輯

回復 10# GBKEE
回GBKEE大，因為看範例vba引數的部份一直無法了解，就是下面程式碼紅色字體的部份，所以想請教GBKEE大關於引數的問題：

--------------------------------------------------------------------------------
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
     ActiveSheet.Name = "pick & num"
     
    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        <<<<<<<這裡出現陣列索引錯誤9，把冒號的錯誤更正還是一樣~~
     myStr = "A" & rowPaste
     Range(myStr).Select
     ActiveSheet.Paste

End Sub
-----------------------------------------
Sub main3()

Dim myRange As Range
Dim myCell, i
Dim mySheet As String


Set myRange = Application.InputBox("Choose the days", Type:=8) '幫我選取我要篩選的範圍
mySheet = InputBox("input the sheet name you analyze") '選擇工作表

addsheetVer2                            '執行上述新增工作表的程式，每次增加的不一樣myRow = 1

For Each myCell In myRange              '在我的myrange裡對每一個mycell，來做下面的事情
    Flag = 0                                 '不符合我的要求就跳到下一圈去看是否有符合
    i = myCell.Row                  
   
    ChooseVer2 i, mySheet                            '選取行檢測是否符合我設的條件
    If Flag = 1 Then                                             'choose子程序把flag改變
        CopyPasteVer2 i, myRow, mySheet, newSheet        
        myRow = myRow + 1
    End If
   
Next
End Sub

TOP

yagami12th

帖子
88 
主題
13 
精華
0 
積分
104 
點名
0  
作業系統
WIN7 
軟體版本
OFFICE2010 
閱讀權限
20 
性別
男 
註冊時間
2012-1-3 
最後登錄
2017-12-31 
9#
發表於 2012-2-27 14:18 | 顯示全部帖子
回復 13# GBKEE

太感謝GBKEE大了:D ，但對於GOTO方法還沒用過，要查一下。

TOP

        靜思自在 : 【時日莫空過】一個人在世間做了多少事，就等於壽命有多長。因此必須與時間競爭，切莫使時日空過。
返回列表 上一主題