GBKEE

回復 10# blue2263
參考這裡

blue2263

感謝G大,提供路徑,我找到原始檔網址位置

blue2263

可否請G大幫我看一下,以下程式碼,我逐步執行(F8)沒問題,但是改用執行巨集時,都會停在
(Sheets("匯總").Select )出現程式碼的執行己被中斷錯誤訊息,不知那個地方有問題

Sub Macro()
'
' Macro Macro
' 報表整合
'

'
  Application.ScreenUpdating = False '讓視窗不跟隨更新變動
  If ActiveCell.Value <> Empty Then
      Application.CutCopyMode = False
    Selection.Copy
   
                Sheets("原始表").Select
                Range("B2").Select

                Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
                    :=False, Transpose:=False '貼上
                    
                    On Error GoTo 101 '   '新增條件開始101
                Sheets("原始表").Range("E7").QueryTable.Refresh BackgroundQuery:=False
                Sheets("匯總").Select
                Range("A2:K21").Select
                Selection.Copy
                Range("A1").Select
                Selection.End(xlDown).Select '到最底資料列
                ActiveCell.Offset(1, 0).Range("A1").Select '下一列
                Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
                    :=False, Transpose:=False '貼上值
                     
101
                Sheets("巨集工作表").Select
                ActiveCell.Offset(1, 0).Range("A1").Select
   Call Macro
      End If
       End Sub

blue2263

G大你好
我後來將程式碼做了下列的更改,就可執行沒問題了
  (Application.ScreenUpdating = False '讓視窗不跟隨更新變動)   去除此行
  Application.Wait (Now + TimeValue("0:00:001"))     '新增此行
   Sheets("匯總").Select

但是為了執行上更快速
我將(讓視窗不跟隨更新變動),此行程式碼加入時,也一樣會有錯誤
請教程式碼要如何更比較好?
麻煩你了感恩謝謝

GBKEE

回復 14# blue2263

我將(讓視窗不跟隨更新變動),此行程式碼加入時,也一樣會有錯誤

你沒附檔,莫宰羊.

blue2263

D股權分散.rar (788.42 KB)

股權分散
下載次數: 15

2014-1-2 19:02

請g大查收圖檔,感恩謝謝

GBKEE

回復 16# blue2263

1. Sub Macro()
   
2.     Application.ScreenUpdating = False '讓視窗不跟隨更新變動
   
3.     If ActiveCell.Value <> Empty Then
   
4.         Application.CutCopyMode = False
   
5.         Selection.Copy
   
6.         Sheets("原始表").Select
   
7.         Range("B2").Select
   
8.         Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
   
9.             :=False, Transpose:=False '貼上
   
10.         On Error GoTo 101 '   '新增條件開始101
    
11.         '*********************************************************************
    
12.         'ActiveCell.Value應是這Sheets("原始表").Range("E7")QueryTable的股票代號
    
13.         '但Sheets("巨集工作表").Select
    
14.         'ActiveCell.Offset(1, 0).Range("A1").Select <-沒有股票代號
    
15.         'Web的更新會錯誤 一直的 GoTo 101
    
16.         Sheets("原始表").Range("E7").QueryTable.Refresh BackgroundQuery:=True
    
17.         '*********************************************************************
    
18.         'Application.Wait (Now + TimeValue("0:00:02"))
    
19.         Sheets("匯總").Select
    
20.         Range("A2:K21").Select
    
21.         Selection.Copy
    
22.         Range("A1").Select
    
23.         Selection.End(xlDown).Select '到最底資料列
    
24.         ActiveCell.Offset(1, 0).Range("A1").Select '下一列
    
25.         Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
    
26.                     :=False, Transpose:=False '貼上值
    
27. 101
    
28.         Sheets("代碼").Select   '修改這裡試試看
    
29.         'Sheets("巨集工作表").Select
    
30.         ActiveCell.Offset(1, 0).Range("A1").Select
    
31.         Call Macro
    
32.     End If
    
33. End Sub

複製代碼

blue2263

g大你好,
是將'Sheets("巨集工作表").Select
改為Sheets("代碼").Select 嗎?
我巨集開始執行,是由(巨集工作表)開始的,
改為由代碼開始執行一樣會有,當掉無回應的問題
不好意思還請再幫我看一下謝謝

GBKEE

回復 18# blue2263

1. Option Explicit
   
2. Sub Ex()
   
3.     Dim Rng(1 To 2) As Range
   
4.     On Error Resume Next  '執行程式碼如有錯誤繼續執行下一個程式碼: 股票Web有錯誤時
   
5.     With Sheets("巨集工作表")
   
6.         Set Rng(1) = .Range("B2")
   
7.         .Activate
   
8.     End With
   
9.     'Sheets("匯總").UsedRange.Offset(1).Clear   '用此程式碼" 如需清除舊有資料
   
10.     Do While Rng(1) <> ""
    
11.         Rng(1).Activate
    
12.         With Sheets("原始表")
    
13.             .Range("B2") = Rng(1)
    
14.             .Range("E7").QueryTable.Refresh BackgroundQuery:=False
    
15.             Set Rng(2) = .Range("A10:K29")   '你要的原始資料            
    
16.         End With
    
17.         If Err = 0 Then
    
18.             Application.StatusBar = Rng(1) & " 匯入中"
    
19.             With Sheets("匯總").Range("A1").End(xlDown).Offset(1)  
    
20.                 .Range("A1:K20").Value = Sheets("匯總").Range("A2:K21").Value
    
21.                 Rng(1).Parent.Hyperlinks.Add Anchor:=Rng(1).Offset(, 2), Address:="", SubAddress:=.Address(, , , 1), TextToDisplay:=.Parent.Name & "!" & .Address(0, 0)
    
22.                 '重新設定超連結
    
23.             End With
    
24.             
    
25.             '************'用此程式碼:配合需清除舊有資料 ******************************
    
26.             'With Sheets("匯總").Range("A" & Sheets("匯總").Rows.Count).End(xlUp).Offset(1)
    
27.             '   .Resize(Rng(2).Rows.Count, Rng(2).Columns.Count) = Rng(2).Value
    
28.             '    Rng(1).Parent.Hyperlinks.Add Anchor:=Rng(1).Offset(, 2), Address:="", SubAddress:=.Address(, , , 1), TextToDisplay:=.Parent.Name & "!" & .Address(0, 0)
    
29.             'End With
    
30.             '********************************************
    
31.             
    
32.         Else
    
33.             With Rng(1).Offset(, 2)
    
34.                 .Hyperlinks.Delete  '股票Web錯誤:刪除超連結
    
35.                 .Value = ""
    
36.             End With
    
37.             Err.Clear
    
38.         End If
    
39.         Set Rng(1) = Rng(1).Offset(1)
    
40.     Loop
    
41.     Application.StatusBar = " 工作 完成 !!"
    
42. End Sub

複製代碼

blue2263

感謝G大的熱心幫忙
G大我發現有個奇怪現象,
當我在執行巨集當中如果想要,暫停巨集,按下組鍵CTRL+ESC+PAUSE,停止巨集後,->然後再次執行巨集會變成無法自動執行巨集,
都會執行一下後中斷,然後出現,(程式碼的執行己被中斷),必須重開電腦,這現象才會消除
以上測試用G大的程式碼或自己的都會是相同情況,