返回列表 上一主題 發帖

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

回復 10# GBKEE

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

TOP

本帖最後由 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

回復 12# yagami12th
  1. Option Explicit
  2. Dim Flag
  3. Dim myRow As Integer
  4. Dim newSheet As String
  5. Private Const XpasteSheet = "pick & num"
  6. 'Private Const "設為模組的私用常數  其值如字面所示    ***指定 貼上的工作表名稱
  7. Sub addsheetVer2()
  8.     Static Num As Integer
  9.     On Error GoTo AD:
  10.     With Sheets(XpasteSheet)
  11.         .Cells.Clear
  12.         Num = Num + 1
  13.     End With
  14.     Exit Sub
  15. AD:
  16.      Sheets.Add(after:=Sheets(Sheets.Count)).Name = XpasteSheet
  17.      ''指名引數,數該excel檔有幾個sheet放在最右邊
  18.     Resume    '返回程序錯誤處
  19. End Sub
  20. Sub ChooseVer2(rowChoose, sheetName As String) '原先只有輸入列號,現在要加上工作表的名字
  21.     If Worksheets(sheetName).Cells(rowChoose, 5) > 10 Then Flag = 1        '只選取指定sheet的資料做篩選
  22. End Sub
  23. Sub CopyPasteVer2(rowCopy, rowPaste, copySheet As String, pasteSheet) 'copy the row rowcopy in sheet with name "2330"
  24.     Dim myStr As String                                                             'and paste to the row rowpaste in the  sheet "pick"
  25.     Sheets(copySheet).Select
  26.     myStr = rowCopy & ":" & rowCopy
  27.     Rows(myStr).Select
  28.     Selection.Copy
  29.     Sheets(pasteSheet).Select
  30.     myStr = "A" & rowPaste
  31.     Range(myStr).Select
  32.     ActiveSheet.Paste
  33. End Sub
  34. Sub main3()
  35.     Dim i As Integer
  36.     Dim myRange As Range
  37.     Dim myCell
  38.     Dim mySheet As String
  39.     mySheet = InputBox("input the sheet name you analyze") '選擇工作表
  40.     Set myRange = Application.InputBox("Choose the days", Type:=8)
  41.     '幫我選取我要篩選的範圍   ** 要選取整列  **
  42.     Set myRange = myRange.SpecialCells(xlCellTypeConstants)   '選取整列有資料的範圍
  43.     addsheetVer2 '執行上述新增工作表的程式,每次增加的不一樣,可以執行上面寫的好幾個副程式,可以讓每個程式分工合作,組合在一起
  44.     myRow = 1
  45.     For Each myCell In myRange '在我的myrange裡對每一個mycell,來做下面的事情
  46.         i = myCell.Row
  47.         Flag = 0 '不符合我的要求就跳到下一圈去看是否有符合
  48.         ChooseVer2 i, mySheet '檢測第20行是否符合我設的條件
  49.         If Flag = 1 Then
  50.             CopyPasteVer2 i, myRow, mySheet, XpasteSheet '在指定的工作表作篩選後貼過去,符合設定條件,貼到新的工作表,因為不是只有第二十行,所以要寫迴圈
  51.             myRow = myRow + 1
  52.         End If
  53.     Next
  54. End Sub
複製代碼

TOP

回復 13# GBKEE

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

TOP

        靜思自在 : 不要小看自己,因為人有無限的可能。
返回列表 上一主題