可以幫我寫迴圈並修正錯誤嗎

本帖最後由 GBKEE 於 2016-1-19 10:17 編輯

Range("K2") 1-140筆資料(可以浮動嗎)
Range("K1") 1--7筆資料(可以浮動嗎)
Sub 完成跑社()
'
' 完成跑社巨集
''
  Range("K2").Select
Application.CutCopyMode = False
ActiveCell.FormulaR1C1 = "1"
   Range("K1").Select
   ActiveCell.FormulaR1C1 = "7"
      執行SUB 志願確定
   Range("K1").Select
   ActiveCell.FormulaR1C1 = "6"
      執行SUB 志願確定
   Range("K1").Select
   ActiveCell.FormulaR1C1 = "5"
      執行SUB 志願確定
   Range("K1").Select
   ActiveCell.FormulaR1C1 = "4"
執行SUB 志願確定
   Range("K1").Select
   ActiveCell.FormulaR1C1 = "3"
執行SUB 志願確定
   Range("K1").Select
   ActiveCell.FormulaR1C1 = "2"
執行SUB 志願確定
Range("K1").Select
   ActiveCell.FormulaR1C1 = "1"
   執行SUB 志願確定
Range("K2").Select
Application.CutCopyMode = False
ActiveCell.FormulaR1C1 = "2"
   Range("K1").Select
   ActiveCell.FormulaR1C1 = "7"
      執行SUB 志願確定
   Range("K1").Select
   ActiveCell.FormulaR1C1 = "6"
      執行SUB 志願確定
   Range("K1").Select
   ActiveCell.FormulaR1C1 = "5"
      執行SUB 志願確定
   Range("K1").Select
   ActiveCell.FormulaR1C1 = "4"
執行SUB 志願確定
   Range("K1").Select
   ActiveCell.FormulaR1C1 = "3"
執行SUB 志願確定
   Range("K1").Select
   ActiveCell.FormulaR1C1 = "2"
執行SUB 志願確定
Range("K1").Select
   ActiveCell.FormulaR1C1 = "1"
   執行SUB 志願確定

End Sub

樓主熱帖

opman

中學生 Rank: 2

帖子: 12
主題: 4
精華: 0
積分: 57
點名: 0
作業系統: W7
軟體版本: EX2010
閱讀權限: 20
性別: 男
來自: 台南市
註冊時間: 2014-11-6
最後登錄: 2018-8-30

2^#

發表於 2016-1-18 13:16 | 只看該作者

回復 1# opman

我自己摸索寫成這樣但持行好久，有辦法縮短時間嗎
Sub 完成跑社()
'
' 完成跑社巨集
'
Dim s As Integer
For s = 1 To 128
Range("K2") = s
Range("K1").Select
ActiveCell.FormulaR1C1 = "7"
      Columns("F:F").Select
Selection.Copy
Range("H1").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
      :=False, Transpose:=False
Selection.Replace What:="N", Replacement:="", LookAt:=xlPart, _
      SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
      ReplaceFormat:=False
Application.CutCopyMode = False
Selection.Copy
Range("C1").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
      :=True, Transpose:=False
Range("K1").Select
ActiveCell.FormulaR1C1 = "6"
      Columns("F:F").Select
Selection.Copy
Range("H1").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
      :=False, Transpose:=False
Selection.Replace What:="N", Replacement:="", LookAt:=xlPart, _
      SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
      ReplaceFormat:=False
Application.CutCopyMode = False
Selection.Copy
Range("C1").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
      :=True, Transpose:=False
Range("K1").Select
ActiveCell.FormulaR1C1 = "5"
      Columns("F:F").Select
Selection.Copy
Range("H1").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
      :=False, Transpose:=False
Selection.Replace What:="N", Replacement:="", LookAt:=xlPart, _
      SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
      ReplaceFormat:=False
Application.CutCopyMode = False
Selection.Copy
Range("C1").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
      :=True, Transpose:=False
Range("K1").Select
ActiveCell.FormulaR1C1 = "4"
      Columns("F:F").Select
Selection.Copy
Range("H1").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
      :=False, Transpose:=False
Selection.Replace What:="N", Replacement:="", LookAt:=xlPart, _
      SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
      ReplaceFormat:=False
Application.CutCopyMode = False
Selection.Copy
Range("C1").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
      :=True, Transpose:=False
Range("K1").Select
ActiveCell.FormulaR1C1 = "3"
      Columns("F:F").Select
Selection.Copy
Range("H1").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
      :=False, Transpose:=False
Selection.Replace What:="N", Replacement:="", LookAt:=xlPart, _
      SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
      ReplaceFormat:=False
Application.CutCopyMode = False
Selection.Copy
Range("C1").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
      :=True, Transpose:=False
Range("K1").Select
ActiveCell.FormulaR1C1 = "2"
      Columns("F:F").Select
Selection.Copy
Range("H1").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
      :=False, Transpose:=False
Selection.Replace What:="N", Replacement:="", LookAt:=xlPart, _
      SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
      ReplaceFormat:=False
Application.CutCopyMode = False
Selection.Copy
Range("C1").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
      :=True, Transpose:=False
Range("K1").Select
ActiveCell.FormulaR1C1 = "1"
         Columns("F:F").Select
Selection.Copy
Range("H1").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
      :=False, Transpose:=False
Selection.Replace What:="N", Replacement:="", LookAt:=xlPart, _
      SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
      ReplaceFormat:=False
Application.CutCopyMode = False
Selection.Copy
Range("C1").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
      :=True, Transpose:=False
  Next s
End Sub

TOP

ML089

版主 Rank: 7 Rank: 7 Rank: 7

帖子: 2025
主題: 13
精華: 0
積分: 2053
點名: 0
作業系統: WIN7
軟體版本: Office2007
閱讀權限: 100
性別: 男
來自: 台北市
註冊時間: 2011-3-2
最後登錄: 2024-3-14

論壇榮譽勳章論壇贊助勳章熱烈參與勳章 2014馬年全勤獎章 2015羊年全勤獎章 2016猴年全勤獎章

3^#

發表於 2016-1-18 16:12 | 只看該作者

回復 1# opman

照原PO文是可以縮減如下

Sub EX()
For Each xK2 In Array("1", "2")
      Range("K2") = xK2
      For Each xK1 In Array("7", "6", "5", "4", "3", "2", "1")
         Range("K1") = xK1
         執行SUB 志願確定
      Next
Next
End Sub

{...} 表示需要用 CTRL+SHIFT+ENTER 三鍵輸入公式

TOP

GBKEE